replace several 'fromJust's with 'expectJust's
[ghc-hetmet.git] / ghc / compiler / typecheck / TcBinds.lhs
index f058aac..cffcb9c 100644 (file)
@@ -1,64 +1,71 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[TcBinds]{TcBinds}
 
 \begin{code}
-module TcBinds ( tcBindsAndThen, tcTopBindsAndThen,
-                tcPragmaSigs, checkSigTyVars, tcBindWithSigs, 
-                sigCtxt, TcSigInfo(..) ) where
+module TcBinds ( tcLocalBinds, tcTopBinds, 
+                tcHsBootSigs, tcMonoBinds, 
+                TcPragFun, tcSpecPrag, tcPrags, mkPragFun,
+                TcSigInfo(..),
+                badBootDeclErr ) where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} TcGRHSs ( tcGRHSsAndBinds )
-
-import HsSyn           ( HsBinds(..), MonoBinds(..), Sig(..), InPat(..),
-                         collectMonoBinders
-                       )
-import RnHsSyn         ( RenamedHsBinds, RenamedSig(..), 
-                         RenamedMonoBinds
+import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
+import {-# SOURCE #-} TcExpr  ( tcMonoExpr )
+
+import DynFlags                ( DynFlag(Opt_MonomorphismRestriction, Opt_GlasgowExts) )
+import HsSyn           ( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..),
+                         HsLocalBinds(..), HsValBinds(..), HsIPBinds(..),
+                         LSig, Match(..), IPBind(..), Prag(..),
+                         HsType(..), LHsType, HsExplicitForAll(..), hsLTyVarNames, 
+                         isVanillaLSig, sigName, placeHolderNames, isPragLSig,
+                         LPat, GRHSs, MatchGroup(..), pprLHsBinds, mkHsCoerce,
+                         collectHsBindBinders, collectPatBinders, pprPatBind, isBangHsBind
                        )
-import TcHsSyn         ( TcHsBinds, TcMonoBinds,
-                         TcIdOcc(..), TcIdBndr, 
-                         tcIdType
-                       )
-
-import TcMonad
-import Inst            ( Inst, LIE, emptyLIE, plusLIE, plusLIEs, InstOrigin(..),
-                         newDicts, tyVarsOfInst, instToId, newMethodWithGivenTy,
-                         zonkInst, pprInsts
-                       )
-import TcEnv           ( tcExtendLocalValEnv, tcLookupLocalValueOK, newLocalId,
-                         tcGetGlobalTyVars, tcExtendGlobalTyVars
-                       )
-import TcMatches       ( tcMatchesFun )
-import TcSimplify      ( tcSimplify, tcSimplifyAndCheck )
-import TcMonoType      ( tcHsType )
-import TcPat           ( tcPat )
+import TcHsSyn         ( zonkId )
+
+import TcRnMonad
+import Inst            ( newDictsAtLoc, newIPDict, instToId )
+import TcEnv           ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2, 
+                         pprBinders, tcLookupLocalId_maybe, tcLookupId,
+                         tcGetGlobalTyVars )
+import TcUnify         ( tcInfer, tcSubExp, unifyTheta, 
+                         bleatEscapedTvs, sigCtxt )
+import TcSimplify      ( tcSimplifyInfer, tcSimplifyInferCheck, 
+                         tcSimplifyRestricted, tcSimplifyIPs )
+import TcHsType                ( tcHsSigType, UserTypeCtxt(..) )
+import TcPat           ( tcPat, PatCtxt(..) )
 import TcSimplify      ( bindInstsOfLocalFuns )
-import TcType          ( TcType, TcThetaType, TcTauType, 
-                         TcTyVarSet, TcTyVar,
-                         newTyVarTy, newTcTyVar, tcInstSigType, tcInstSigTcType,
-                         zonkTcType, zonkTcTypes, zonkTcThetaType, zonkTcTyVar
-                       )
-import Unify           ( unifyTauTy, unifyTauTyLists )
-
-import Kind            ( isUnboxedTypeKind, mkTypeKind, isTypeKind, mkBoxedTypeKind )
-import Id              ( GenId, idType, mkUserId )
-import IdInfo          ( noIdInfo )
-import Maybes          ( maybeToBool, assocMaybe )
-import Name            ( getOccName, getSrcLoc, Name )
-import PragmaInfo      ( PragmaInfo(..) )
-import Type            ( mkTyVarTy, mkTyVarTys, isTyVarTy, tyVarsOfTypes,
-                         splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, mkDictTy,
-                         splitRhoTy, mkForAllTy, splitForAllTys )
-import TyVar           ( GenTyVar, TyVar, tyVarKind, mkTyVarSet, minusTyVarSet, emptyTyVarSet,
-                         elementOfTyVarSet, unionTyVarSets, tyVarSetToList )
-import Bag             ( bagToList, foldrBag, )
-import Util            ( isIn, hasNoDups, assoc )
-import Unique          ( Unique )
-import BasicTypes      ( TopLevelFlag(..), RecFlag(..) )
-import SrcLoc           ( SrcLoc )
+import TcMType         ( newFlexiTyVarTy, zonkQuantifiedTyVar, zonkSigTyVar,
+                         tcInstSigTyVars, tcInstSkolTyVars, tcInstType, 
+                         zonkTcType, zonkTcTypes, zonkTcTyVars )
+import TcType          ( TcType, TcTyVar, TcThetaType, 
+                         SkolemInfo(SigSkol), UserTypeCtxt(FunSigCtxt), 
+                         TcTauType, TcSigmaType, isUnboxedTupleType,
+                         mkTyVarTy, mkForAllTys, mkFunTys, exactTyVarsOfType, 
+                         mkForAllTy, isUnLiftedType, tcGetTyVar, 
+                         mkTyVarTys, tidyOpenTyVar )
+import Kind            ( argTypeKind )
+import VarEnv          ( TyVarEnv, emptyVarEnv, lookupVarEnv, extendVarEnv ) 
+import TysWiredIn      ( unitTy )
+import TysPrim         ( alphaTyVar )
+import Id              ( Id, mkLocalId, mkVanillaGlobal )
+import IdInfo          ( vanillaIdInfo )
+import Var             ( TyVar, idType, idName )
+import Name            ( Name )
+import NameSet
+import NameEnv
+import VarSet
+import SrcLoc          ( Located(..), unLoc, getLoc )
+import Bag
+import ErrUtils                ( Message )
+import Digraph         ( SCC(..), stronglyConnComp )
+import Maybes          ( expectJust, isJust, isNothing, orElse )
+import Util            ( singleton )
+import BasicTypes      ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
+                         RecFlag(..), isNonRec, InlineSpec, defaultInlineSpec )
 import Outputable
 \end{code}
 
@@ -95,351 +102,736 @@ At the top-level the LIE is sure to contain nothing but constant
 dictionaries, which we resolve at the module level.
 
 \begin{code}
-tcTopBindsAndThen, tcBindsAndThen
-       :: (RecFlag -> TcMonoBinds s -> this -> that)           -- Combinator
-       -> RenamedHsBinds
-       -> TcM s (this, LIE s)
-       -> TcM s (that, LIE s)
-
-tcTopBindsAndThen = tc_binds_and_then TopLevel
-tcBindsAndThen    = tc_binds_and_then NotTopLevel
-
-tc_binds_and_then top_lvl combiner binds do_next
-  = tcBinds top_lvl binds      `thenTc` \ (mbinds1, binds_lie, env, ids) ->
-    tcSetEnv env               $
-
-       -- Now do whatever happens next, in the augmented envt
-    do_next                    `thenTc` \ (thing, thing_lie) ->
-
-       -- Create specialisations of functions bound here
-       -- Nota Bene: we glom the bindings all together in a single
-       -- recursive group ("recursive" passed to combiner, below)
-       -- so that we can do thsi bindInsts thing once for all the bindings
-       -- and the thing inside.  This saves a quadratic-cost algorithm
-       -- when there's a long sequence of bindings.
-    bindInstsOfLocalFuns (binds_lie `plusLIE` thing_lie) ids   `thenTc` \ (final_lie, mbinds2) ->
-
-       -- All done
-    let
-       final_mbinds = mbinds1 `AndMonoBinds` mbinds2
-    in
-    returnTc (combiner Recursive final_mbinds thing, final_lie)
-
-tcBinds :: TopLevelFlag
-       -> RenamedHsBinds
-       -> TcM s (TcMonoBinds s, LIE s, TcEnv s, [TcIdBndr s])
-          -- The envt is the envt with binders in scope
-          -- The binders are those bound by this group of bindings
-
-tcBinds top_lvl EmptyBinds
-  = tcGetEnv           `thenNF_Tc` \ env ->
-    returnTc (EmptyMonoBinds, emptyLIE, env, [])
-
-  -- Short-cut for the rather common case of an empty bunch of bindings
-tcBinds top_lvl (MonoBind EmptyMonoBinds sigs is_rec)
-  = tcGetEnv           `thenNF_Tc` \ env ->
-    returnTc (EmptyMonoBinds, emptyLIE, env, [])
-
-tcBinds top_lvl (ThenBinds binds1 binds2)
-  = tcBinds top_lvl binds1       `thenTc` \ (mbinds1, lie1, env1, ids1) ->
-    tcSetEnv env1                $
-    tcBinds top_lvl binds2       `thenTc` \ (mbinds2, lie2, env2, ids2) ->
-    returnTc (mbinds1 `AndMonoBinds` mbinds2, lie1 `plusLIE` lie2, env2, ids1++ids2)
-    
-tcBinds top_lvl (MonoBind bind sigs is_rec)
-  = fixTc (\ ~(prag_info_fn, _) ->
-       -- This is the usual prag_info fix; the PragmaInfo field of an Id
-       -- is not inspected till ages later in the compiler, so there
-       -- should be no black-hole problems here.
-
-       -- TYPECHECK THE SIGNATURES
-      mapTc (tcTySig prag_info_fn) ty_sigs             `thenTc` \ tc_ty_sigs ->
-  
-      tcBindWithSigs top_lvl binder_names bind 
-                    tc_ty_sigs is_rec prag_info_fn     `thenTc` \ (poly_binds, poly_lie, poly_ids) ->
-  
-         -- Extend the environment to bind the new polymorphic Ids
-      tcExtendLocalValEnv binder_names poly_ids $
-  
-         -- Build bindings and IdInfos corresponding to user pragmas
-      tcPragmaSigs sigs                        `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
-  
-         -- Catch the environment and return
-      tcGetEnv                      `thenNF_Tc` \ env ->
-      returnTc (prag_info_fn, (poly_binds `AndMonoBinds` prag_binds, 
-                              poly_lie `plusLIE` prag_lie, 
-                              env, poly_ids)
-    ) )                                        `thenTc` \ (_, result) ->
-    returnTc result
+tcTopBinds :: HsValBinds Name -> TcM (LHsBinds TcId, TcLclEnv)
+       -- Note: returning the TcLclEnv is more than we really
+       --       want.  The bit we care about is the local bindings
+       --       and the free type variables thereof
+tcTopBinds binds
+  = do { (ValBindsOut prs _, env) <- tcValBinds TopLevel binds getLclEnv
+       ; return (foldr (unionBags . snd) emptyBag prs, env) }
+       -- The top level bindings are flattened into a giant 
+       -- implicitly-mutually-recursive LHsBinds
+
+tcHsBootSigs :: HsValBinds Name -> TcM [Id]
+-- A hs-boot file has only one BindGroup, and it only has type
+-- signatures in it.  The renamer checked all this
+tcHsBootSigs (ValBindsOut binds sigs)
+  = do { checkTc (null binds) badBootDeclErr
+       ; mapM (addLocM tc_boot_sig) (filter isVanillaLSig sigs) }
   where
-    binder_names = map fst (bagToList (collectMonoBinders bind))
-    ty_sigs      = [sig  | sig@(Sig name _ _) <- sigs]
-\end{code}
+    tc_boot_sig (TypeSig (L _ name) ty)
+      = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
+          ; return (mkVanillaGlobal name sigma_ty vanillaIdInfo) }
+       -- Notice that we make GlobalIds, not LocalIds
+tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups)
+
+badBootDeclErr :: Message
+badBootDeclErr = ptext SLIT("Illegal declarations in an hs-boot file")
+
+------------------------
+tcLocalBinds :: HsLocalBinds Name -> TcM thing
+            -> TcM (HsLocalBinds TcId, thing)
+
+tcLocalBinds EmptyLocalBinds thing_inside 
+  = do { thing <- thing_inside
+       ; return (EmptyLocalBinds, thing) }
+
+tcLocalBinds (HsValBinds binds) thing_inside
+  = do { (binds', thing) <- tcValBinds NotTopLevel 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
+
+       -- 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) }
+  where
+       -- I wonder if we should do these one at at time
+       -- Consider     ?x = 4
+       --              ?y = ?x + 1
+    tc_ip_bind (IPBind ip expr)
+      = newFlexiTyVarTy argTypeKind            `thenM` \ ty ->
+       newIPDict (IPBindOrigin ip) ip ty       `thenM` \ (ip', ip_inst) ->
+       tcMonoExpr expr ty                      `thenM` \ expr' ->
+       returnM (ip_inst, (IPBind ip' expr'))
+
+------------------------
+tcValBinds :: TopLevelFlag 
+          -> HsValBinds Name -> TcM thing
+          -> TcM (HsValBinds TcId, thing) 
+
+tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside
+  = pprPanic "tcValBinds" (ppr binds)
+
+tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
+  = do         {       -- Typecheck the signature
+       ; let { prag_fn = mkPragFun sigs
+             ; ty_sigs = filter isVanillaLSig sigs
+             ; sig_fn  = mkSigFun ty_sigs }
+
+       ; poly_ids <- mapM tcTySig ty_sigs
+
+               -- Extend the envt right away with all 
+               -- the Ids declared with type signatures
+       ; (binds', thing) <- tcExtendIdEnv poly_ids $
+                            tc_val_binds top_lvl sig_fn prag_fn 
+                                         binds thing_inside
+
+       ; return (ValBindsOut binds' sigs, thing) }
+
+------------------------
+tc_val_binds :: TopLevelFlag -> TcSigFun -> TcPragFun
+            -> [(RecFlag, LHsBinds Name)] -> TcM thing
+            -> TcM ([(RecFlag, LHsBinds TcId)], thing)
+-- Typecheck a whole lot of value bindings,
+-- one strongly-connected component at a time
+
+tc_val_binds top_lvl sig_fn prag_fn [] thing_inside
+  = do { thing <- thing_inside
+       ; return ([], thing) }
+
+tc_val_binds top_lvl sig_fn prag_fn (group : groups) thing_inside
+  = do { (group', (groups', thing))
+               <- tc_group top_lvl sig_fn prag_fn group $ 
+                  tc_val_binds top_lvl sig_fn prag_fn groups thing_inside
+       ; return (group' ++ groups', thing) }
+
+------------------------
+tc_group :: TopLevelFlag -> TcSigFun -> TcPragFun
+        -> (RecFlag, LHsBinds Name) -> TcM thing
+        -> TcM ([(RecFlag, LHsBinds TcId)], thing)
+
+-- Typecheck one strongly-connected component of the original program.
+-- 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
+  =    -- A single non-recursive binding
+       -- We want to keep non-recursive things non-recursive
+        -- so that we desugar unlifted bindings correctly
+    do { (binds, thing) <- tcPolyBinds top_lvl NonRecursive NonRecursive
+                                       sig_fn prag_fn binds thing_inside
+       ; return ([(NonRecursive, b) | b <- binds], thing) }
+
+tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
+  =    -- A recursive strongly-connected component
+       -- To maximise polymorphism (with -fglasgow-exts), we do a new 
+       -- strongly-connected-component analysis, this time omitting 
+       -- any references to variables with type signatures.
+       --
+       -- Then we bring into scope all the variables with type signatures
+    do { traceTc (text "tc_group rec" <+> pprLHsBinds binds)
+       ; gla_exts     <- doptM Opt_GlasgowExts
+       ; (binds,thing) <- if gla_exts 
+                          then go new_sccs
+                          else tc_binds Recursive binds thing_inside
+       ; return ([(Recursive, unionManyBags binds)], thing) }
+               -- Rec them all together
+  where
+    new_sccs :: [SCC (LHsBind Name)]
+    new_sccs = stronglyConnComp (mkEdges sig_fn binds)
+
+--  go :: SCC (LHsBind Name) -> TcM ([LHsBind TcId], thing)
+    go (scc:sccs) = do { (binds1, (binds2, thing)) <- go1 scc (go sccs)
+                       ; return (binds1 ++ binds2, thing) }
+    go []        = do  { thing <- thing_inside; return ([], thing) }
+
+    go1 (AcyclicSCC bind) = tc_binds NonRecursive (unitBag bind)
+    go1 (CyclicSCC binds) = tc_binds Recursive    (listToBag binds)
+
+    tc_binds rec_tc binds = tcPolyBinds top_lvl Recursive rec_tc sig_fn prag_fn binds
 
-An aside.  The original version of @tcBindsAndThen@ which lacks a
-combiner function, appears below.  Though it is perfectly well
-behaved, it cannot be typed by Haskell, because the recursive call is
-at a different type to the definition itself.  There aren't too many
-examples of this, which is why I thought it worth preserving! [SLPJ]
+------------------------
+mkEdges :: TcSigFun -> LHsBinds Name
+       -> [(LHsBind Name, BKey, [BKey])]
+
+type BKey  = Int -- Just number off the bindings
+
+mkEdges sig_fn binds
+  = [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc bind)),
+                        Just key <- [lookupNameEnv key_map n], no_sig n ])
+    | (bind, key) <- keyd_binds
+    ]
+  where
+    no_sig :: Name -> Bool
+    no_sig n = isNothing (sig_fn n)
+
+    keyd_binds = bagToList binds `zip` [0::BKey ..]
+
+    key_map :: NameEnv BKey    -- Which binding it comes from
+    key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
+                                    , bndr <- bindersOfHsBind bind ]
+
+bindersOfHsBind :: HsBind Name -> [Name]
+bindersOfHsBind (PatBind { pat_lhs = pat })  = collectPatBinders pat
+bindersOfHsBind (FunBind { fun_id = L _ f }) = [f]
+
+------------------------
+tcPolyBinds :: TopLevelFlag 
+           -> RecFlag                  -- Whether the group is really recursive
+           -> RecFlag                  -- Whether it's recursive for typechecking purposes
+           -> TcSigFun -> TcPragFun
+           -> LHsBinds Name
+           -> TcM thing
+           -> TcM ([LHsBinds TcId], thing)
+
+-- Typechecks a single bunch of bindings all together, 
+-- and generalises them.  The bunch may be only part of a recursive
+-- group, because we use type signatures to maximise polymorphism
+--
+-- Deals with the bindInstsOfLocalFuns thing too
+--
+-- Returns a list because the input may be a single non-recursive binding,
+-- in which case the dependency order of the resulting bindings is
+-- important.  
+
+tcPolyBinds top_lvl rec_group rec_tc sig_fn prag_fn scc thing_inside
+  =    -- NB: polymorphic recursion means that a function
+       -- may use an instance of itself, we must look at the LIE arising
+       -- from the function's own right hand side.  Hence the getLIE
+       -- encloses the tc_poly_binds. 
+    do { traceTc (text "tcPolyBinds" <+> ppr scc)
+       ; ((binds1, poly_ids, thing), lie) <- getLIE $ 
+               do { (binds1, poly_ids) <- tc_poly_binds top_lvl rec_group rec_tc
+                                                        sig_fn prag_fn scc
+                  ; thing <- tcExtendIdEnv poly_ids thing_inside
+                  ; return (binds1, poly_ids, thing) }
+
+       ; if isTopLevel top_lvl 
+         then          -- For the top level don't bother will all this
+                       -- bindInstsOfLocalFuns stuff. All the top level 
+                       -- things are rec'd together anyway, so it's fine to
+                       -- leave them to the tcSimplifyTop, 
+                       -- and quite a bit faster too
+               do { extendLIEs lie; return (binds1, thing) }
+
+         else do       -- Nested case
+               { lie_binds <- bindInstsOfLocalFuns lie poly_ids
+               ; return (binds1 ++ [lie_binds], thing) }}
+
+------------------------
+tc_poly_binds :: TopLevelFlag          -- See comments on tcPolyBinds
+             -> RecFlag -> RecFlag
+             -> TcSigFun -> TcPragFun
+             -> LHsBinds Name
+             -> TcM ([LHsBinds TcId], [TcId])
+-- Typechecks the bindings themselves
+-- Knows nothing about the scope of the bindings
+
+tc_poly_binds top_lvl rec_group rec_tc sig_fn prag_fn binds
+  = let 
+        binder_names = collectHsBindBinders binds
+       bind_list    = bagToList 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                             $
+    recoverM (recoveryCode binder_names)       $ do 
+
+  { traceTc (ptext SLIT("------------------------------------------------"))
+  ; traceTc (ptext SLIT("Bindings for") <+> ppr binder_names)
+
+       -- TYPECHECK THE BINDINGS
+  ; ((binds', mono_bind_infos), lie_req) 
+       <- getLIE (tcMonoBinds bind_list sig_fn rec_tc)
+
+       -- CHECK FOR UNLIFTED BINDINGS
+       -- 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, Nothing,  mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id, [])
+             mk_export (name, Just sig, mono_id) mono_ty = ([], sig_id sig,             mono_id, [])
+                       -- ToDo: prags for unlifted bindings
+
+       ; return ( [unitBag $ L loc $ AbsBinds [] [] exports binds'],
+                  [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked
+
+    else do    -- The normal lifted case: GENERALISE
+  { is_unres <- isUnRestrictedGroup bind_list sig_fn
+  ; (tyvars_to_gen, dict_binds, dict_ids)
+       <- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
+          generalise top_lvl is_unres mono_bind_infos lie_req
+
+       -- FINALISE THE QUANTIFIED TYPE VARIABLES
+       -- The quantified type variables often include meta type variables
+       -- we want to freeze them into ordinary type variables, and
+       -- default their kind (e.g. from OpenTypeKind to TypeKind)
+  ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen
+
+       -- BUILD THE POLYMORPHIC RESULT IDs
+  ; exports <- mapM (mkExport prag_fn tyvars_to_gen' (map idType dict_ids))
+                   mono_bind_infos
+
+       -- ZONK THE poly_ids, because they are used to extend the type 
+       -- environment; see the invariant on TcEnv.tcExtendIdEnv 
+  ; let        poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
+  ; zonked_poly_ids <- mappM zonkId poly_ids
+
+  ; traceTc (text "binding:" <+> ppr (zonked_poly_ids `zip` map idType zonked_poly_ids))
+
+  ; let abs_bind = L loc $ AbsBinds tyvars_to_gen'
+                                   dict_ids exports
+                                   (dict_binds `unionBags` binds')
+
+  ; return ([unitBag abs_bind], zonked_poly_ids)
+  } }
+
+
+--------------
+mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo
+        -> TcM ([TyVar], Id, Id, [Prag])
+mkExport prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id)
+  = case mb_sig of
+      Nothing  -> do { prags <- tcPrags poly_id (prag_fn poly_name)
+                    ; return (inferred_tvs, poly_id, mono_id, prags) }
+         where
+           poly_id = mkLocalId poly_name poly_ty
+           poly_ty = mkForAllTys inferred_tvs
+                                      $ mkFunTys dict_tys 
+                                      $ idType mono_id
+
+      Just sig -> do { let poly_id = sig_id sig
+                    ; prags <- tcPrags poly_id (prag_fn poly_name)
+                    ; sig_tys <- zonkTcTyVars (sig_tvs sig)
+                    ; let sig_tvs' = map (tcGetTyVar "mkExport") sig_tys
+                    ; return (sig_tvs', poly_id, mono_id, prags) }
+               -- We zonk the sig_tvs here so that the export triple
+               -- always has zonked type variables; 
+               -- a convenient invariant
+
+
+------------------------
+type TcPragFun = Name -> [LSig Name]
+
+mkPragFun :: [LSig Name] -> TcPragFun
+mkPragFun sigs = \n -> lookupNameEnv env n `orElse` []
+       where
+         prs = [(expectJust "mkPragFun" (sigName sig), sig) 
+               | sig <- sigs, isPragLSig sig]
+         env = foldl add emptyNameEnv prs
+         add env (n,p) = extendNameEnv_Acc (:) singleton env n p
+
+tcPrags :: Id -> [LSig Name] -> TcM [Prag]
+tcPrags poly_id prags = mapM tc_prag prags
+  where
+    tc_prag (L loc prag) = setSrcSpan loc $ 
+                          addErrCtxt (pragSigCtxt prag) $ 
+                          tcPrag poly_id prag
 
-\begin{pseudocode}
-tcBindsAndThen
-       :: RenamedHsBinds
-       -> TcM s (thing, LIE s, thing_ty))
-       -> TcM s ((TcHsBinds s, thing), LIE s, thing_ty)
+pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag)
 
-tcBindsAndThen EmptyBinds do_next
-  = do_next            `thenTc` \ (thing, lie, thing_ty) ->
-    returnTc ((EmptyBinds, thing), lie, thing_ty)
+tcPrag :: TcId -> Sig Name -> TcM Prag
+tcPrag poly_id (SpecSig orig_name hs_ty inl) = tcSpecPrag poly_id hs_ty inl
+tcPrag poly_id (SpecInstSig hs_ty)          = tcSpecPrag poly_id hs_ty defaultInlineSpec
+tcPrag poly_id (InlineSig v inl)             = return (InlinePrag inl)
 
-tcBindsAndThen (ThenBinds binds1 binds2) do_next
-  = tcBindsAndThen binds1 (tcBindsAndThen binds2 do_next)
-       `thenTc` \ ((binds1', (binds2', thing')), lie1, thing_ty) ->
 
-    returnTc ((binds1' `ThenBinds` binds2', thing'), lie1, thing_ty)
+tcSpecPrag :: TcId -> LHsType Name -> InlineSpec -> TcM Prag
+tcSpecPrag poly_id hs_ty inl
+  = do { spec_ty <- tcHsSigType (FunSigCtxt (idName poly_id)) hs_ty
+       ; (co_fn, lie) <- getLIE (tcSubExp (idType poly_id) spec_ty)
+       ; extendLIEs lie
+       ; let const_dicts = map instToId lie
+       ; return (SpecPrag (mkHsCoerce co_fn (HsVar poly_id)) spec_ty const_dicts inl) }
+  
+--------------
+-- If typechecking the binds fails, then return with each
+-- signature-less binder given type (forall a.a), to minimise 
+-- subsequent error messages
+recoveryCode binder_names
+  = do { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names)
+       ; poly_ids <- mapM mk_dummy binder_names
+       ; return ([], poly_ids) }
+  where
+    mk_dummy name = do { mb_id <- tcLookupLocalId_maybe name
+                       ; case mb_id of
+                             Just id -> return id              -- Had signature, was in envt
+                             Nothing -> 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) 
+       ; 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 other           = return ()
+
+strictBindErr flavour unlifted mbind
+  = hang (text flavour <+> msg <+> ptext SLIT("aren't allowed:")) 4 (ppr mbind)
+  where
+    msg | unlifted  = ptext SLIT("bindings for unlifted types")
+       | otherwise = ptext SLIT("bang-pattern bindings")
 
-tcBindsAndThen (MonoBind bind sigs is_rec) do_next
-  = tcBindAndThen bind sigs do_next
-\end{pseudocode}
+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")
+\end{code}
 
 
 %************************************************************************
 %*                                                                     *
-\subsection{tcBindWithSigs}
+\subsection{tcMonoBind}
 %*                                                                     *
 %************************************************************************
 
-@tcBindWithSigs@ deals with a single binding group.  It does generalisation,
-so all the clever stuff is in here.
+@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
+The signatures have been dealt with already.
 
-* binder_names and mbind must define the same set of Names
+\begin{code}
+tcMonoBinds :: [LHsBind Name]
+           -> TcSigFun
+           -> 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
+           -> TcM (LHsBinds TcId, [MonoBindInfo])
+
+tcMonoBinds [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
+  =    -- 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
+       -- e.g.         f = \(x::forall a. a->a) -> <body>
+       --      We want to infer a higher-rank type for f
+    setSrcSpan b_loc   $
+    do { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name 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
+       ; 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 })),
+                 [(name, Nothing, mono_id)]) }
+
+tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, 
+                               fun_matches = matches, bind_fvs = fvs })]
+           sig_fn              -- Single function binding
+           non_rec     
+  | Just sig <- 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 sig
+       ; 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) <- sig_scoped tc_sig `zip` sig_tvs tc_sig ]
+
+       ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs    $
+                              tcMatchesFun mono_name matches mono_ty
+
+       ; 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 }
+       ; return (unitBag (L b_loc fun_bind'),
+                 [(name, Just tc_sig, mono_id)]) }
+
+tcMonoBinds binds sig_fn non_rec
+  = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn)) 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.)
+
+       ; binds' <- tcExtendIdEnv2    rhs_id_env $
+                   traceTc (text "tcMonoBinds" <+> vcat [ ppr n <+> ppr id <+> ppr (idType id) 
+                                                        | (n,id) <- rhs_id_env]) `thenM_`
+                   mapM (wrapLocM tcRhs) tc_binds
+       ; return (listToBag binds', mono_info) }
+
+------------------------
+-- tcLhs typechecks the LHS of the bindings, to construct the environment in which
+-- we typecheck the RHSs.  Basically what we are doing is this: for each binder:
+--     if there's a signature for it, use the instantiated signature type
+--     otherwise invent a type variable
+-- You see that quite directly in the FunBind case.
+-- 
+-- But there's a complication for pattern bindings:
+--     data T = MkT (forall a. a->a)
+--     MkT f = e
+-- Here we can guess a type variable for the entire LHS (which will be refined to T)
+-- but we want to get (f::forall a. a->a) as the RHS environment.
+-- The simplest way to do this is to typecheck the pattern, and then look up the
+-- bound mono-ids.  Then we want to retain the typechecked pattern to avoid re-doing
+-- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
+
+data TcMonoBind                -- Half completed; LHS done, RHS not done
+  = TcFunBind  MonoBindInfo  (Located TcId) Bool (MatchGroup Name) 
+  | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType
+
+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
+       ; 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
 
-* The Names in tc_ty_sigs must be a subset of binder_names
+tcLhs sig_fn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss })
+  = do { mb_sigs <- mapM (tcInstSig_maybe . sig_fn) names
 
-* The Ids in tc_ty_sigs don't necessarily have to have the same name
-  as the Name in the tc_ty_sig
+       ; let nm_sig_prs  = names `zip` mb_sigs
+             tau_sig_env = mkNameEnv [ (name, sig_tau sig) | (name, Just sig) <- nm_sig_prs]
+             sig_tau_fn  = lookupNameEnv tau_sig_env
 
-\begin{code}
-tcBindWithSigs 
-       :: TopLevelFlag
-       -> [Name]
-       -> RenamedMonoBinds
-       -> [TcSigInfo s]
-       -> RecFlag
-       -> (Name -> PragmaInfo)
-       -> TcM s (TcMonoBinds s, LIE s, [TcIdBndr s])
-
-tcBindWithSigs top_lvl binder_names mbind tc_ty_sigs is_rec prag_info_fn
-  = recoverTc (
-       -- If typechecking the binds fails, then return with each
-       -- signature-less binder given type (forall a.a), to minimise subsequent
-       -- error messages
-       newTcTyVar mkBoxedTypeKind              `thenNF_Tc` \ alpha_tv ->
-       let
-         forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv)
-         poly_ids   = map mk_dummy binder_names
-         mk_dummy name = case maybeSig tc_ty_sigs name of
-                           Just (TySigInfo _ poly_id _ _ _ _) -> poly_id       -- Signature
-                           Nothing -> mkUserId name forall_a_a NoPragmaInfo    -- No signature
-       in
-       returnTc (EmptyMonoBinds, emptyLIE, poly_ids)
-    ) $
-
-       -- Create a new identifier for each binder, with each being given
-       -- a fresh unique, and a type-variable type.
-       -- For "mono_lies" see comments about polymorphic recursion at the 
-       -- end of the function.
-    mapAndUnzipNF_Tc mk_mono_id binder_names   `thenNF_Tc` \ (mono_lies, mono_ids) ->
-    let
-       mono_lie = plusLIEs mono_lies
-       mono_id_tys = map idType mono_ids
-    in
+             tc_pat exp_ty = tcPat (LetPat sig_tau_fn) pat exp_ty unitTy $ \ _ ->
+                             mapM lookup_info nm_sig_prs
+               -- The unitTy is a bit bogus; it's the "result type" for lookup_info.  
 
-       -- TYPECHECK THE BINDINGS
-    tcMonoBinds mbind binder_names mono_ids tc_ty_sigs `thenTc` \ (mbind', lie) ->
+               -- 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) }
 
-       -- CHECK THAT THE SIGNATURES MATCH
-       -- (must do this before getTyVarsToGen)
-    checkSigMatch tc_ty_sigs                           `thenTc` \ sig_theta ->
-       
-       -- COMPUTE VARIABLES OVER WHICH TO QUANTIFY, namely tyvars_to_gen
-       -- The tyvars_not_to_gen are free in the environment, and hence
-       -- candidates for generalisation, but sometimes the monomorphism
-       -- restriction means we can't generalise them nevertheless
-    getTyVarsToGen is_unrestricted mono_id_tys lie     `thenTc` \ (tyvars_not_to_gen, tyvars_to_gen) ->
-
-       -- DEAL WITH TYPE VARIABLE KINDS
-       -- **** This step can do unification => keep other zonking after this ****
-    mapTc defaultUncommittedTyVar (tyVarSetToList tyvars_to_gen)       `thenTc` \ real_tyvars_to_gen_list ->
-    let
-       real_tyvars_to_gen = mkTyVarSet real_tyvars_to_gen_list
-               -- It's important that the final list 
-               -- (real_tyvars_to_gen and real_tyvars_to_gen_list) is fully
-               -- zonked, *including boxity*, because they'll be included in the forall types of
-               -- the polymorphic Ids, and instances of these Ids will be generated from them.
-               -- 
-               -- Also NB that tcSimplify takes zonked tyvars as its arg, hence we pass
-               -- real_tyvars_to_gen
-               --
-    in
-
-       -- SIMPLIFY THE LIE
-    tcExtendGlobalTyVars (tyVarSetToList tyvars_not_to_gen) (
-       if null tc_ty_sigs then
-               -- No signatures, so just simplify the lie
-               -- NB: no signatures => no polymorphic recursion, so no
-               -- need to use mono_lies (which will be empty anyway)
-           tcSimplify (text "tcBinds1" <+> ppr binder_names)
-                      top_lvl real_tyvars_to_gen lie   `thenTc` \ (lie_free, dict_binds, lie_bound) ->
-           returnTc (lie_free, dict_binds, map instToId (bagToList lie_bound))
-
-       else
-           zonkTcThetaType sig_theta                   `thenNF_Tc` \ sig_theta' ->
-           newDicts SignatureOrigin sig_theta'         `thenNF_Tc` \ (dicts_sig, dict_ids) ->
-               -- It's important that sig_theta is zonked, because
-               -- dict_id is later used to form the type of the polymorphic thing,
-               -- and forall-types must be zonked so far as their bound variables
-               -- are concerned
-
-           let
-               -- The "givens" is the stuff available.  We get that from
-               -- the context of the type signature, BUT ALSO the mono_lie
-               -- so that polymorphic recursion works right (see comments at end of fn)
-               givens = dicts_sig `plusLIE` mono_lie
-           in
-
-               -- Check that the needed dicts can be expressed in
-               -- terms of the signature ones
-           tcAddErrCtxt  (bindSigsCtxt tysig_names) $
-           tcSimplifyAndCheck
-               (ptext SLIT("type signature for") <+> 
-                hsep (punctuate comma (map (quotes . ppr) binder_names)))
-               real_tyvars_to_gen givens lie           `thenTc` \ (lie_free, dict_binds) ->
-
-           returnTc (lie_free, dict_binds, dict_ids)
-
-    )                                          `thenTc` \ (lie_free, dict_binds, dicts_bound) ->
-
-    ASSERT( not (any (isUnboxedTypeKind . tyVarKind) real_tyvars_to_gen_list) )
-               -- The instCantBeGeneralised stuff in tcSimplify should have
-               -- already raised an error if we're trying to generalise an unboxed tyvar
-               -- (NB: unboxed tyvars are always introduced along with a class constraint)
-               -- and it's better done there because we have more precise origin information.
-               -- That's why we just use an ASSERT here.
-
-        -- BUILD THE POLYMORPHIC RESULT IDs
-    zonkTcTypes mono_id_tys                    `thenNF_Tc` \ zonked_mono_id_types ->
-    let
-       exports  = zipWith3 mk_export binder_names mono_ids zonked_mono_id_types
-       dict_tys = map tcIdType dicts_bound
-
-       mk_export binder_name mono_id zonked_mono_id_ty
-         | maybeToBool maybe_sig = (sig_tyvars,              TcId sig_poly_id, TcId mono_id)
-         | otherwise             = (real_tyvars_to_gen_list, TcId poly_id,     TcId mono_id)
-         where
-           maybe_sig = maybeSig tc_ty_sigs binder_name
-           Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _) = maybe_sig
-           poly_id = mkUserId binder_name poly_ty (prag_info_fn binder_name)
-           poly_ty = mkForAllTys real_tyvars_to_gen_list $ mkFunTys dict_tys $ zonked_mono_id_ty
-                               -- It's important to build a fully-zonked poly_ty, because
-                               -- we'll slurp out its free type variables when extending the
-                               -- local environment (tcExtendLocalValEnv); if it's not zonked
-                               -- it appears to have free tyvars that aren't actually free at all.
-    in
+       ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
+                                    tcInfer tc_pat
 
-        -- BUILD RESULTS
-    returnTc (
-        AbsBinds real_tyvars_to_gen_list
-                 dicts_bound
-                 exports
-                 (dict_binds `AndMonoBinds` mbind'),
-        lie_free,
-        [poly_id | (_, TcId poly_id, _) <- exports]
-    )
+       ; return (TcPatBind infos pat' grhss pat_ty) }
   where
-    no_of_binders = length binder_names
-
-    mk_mono_id binder_name
-      |  theres_a_signature    -- There's a signature; and it's overloaded, 
-      && not (null sig_theta)  -- so make a Method
-      = tcAddSrcLoc sig_loc $
-       newMethodWithGivenTy SignatureOrigin 
-               (TcId poly_id) (mkTyVarTys sig_tyvars) 
-               sig_theta sig_tau                       `thenNF_Tc` \ (mono_lie, TcId mono_id) ->
-                                                       -- A bit turgid to have to strip the TcId
-       returnNF_Tc (mono_lie, mono_id)
-
-      | otherwise              -- No signature or not overloaded; 
-      = tcAddSrcLoc (getSrcLoc binder_name) $
-       (if theres_a_signature then
-               returnNF_Tc sig_tau     -- Non-overloaded signature; use its type
-        else
-               newTyVarTy kind         -- No signature; use a new type variable
-       )                                       `thenNF_Tc` \ mono_id_ty ->
-
-       newLocalId (getOccName binder_name) mono_id_ty  `thenNF_Tc` \ mono_id ->
-       returnNF_Tc (emptyLIE, mono_id)
-      where
-       maybe_sig          = maybeSig tc_ty_sigs binder_name
-       theres_a_signature = maybeToBool maybe_sig
-       Just (TySigInfo name poly_id sig_tyvars sig_theta sig_tau sig_loc) = maybe_sig
-
-    tysig_names     = [name | (TySigInfo name _ _ _ _ _) <- tc_ty_sigs]
-    is_unrestricted = isUnRestrictedGroup tysig_names mbind
-
-    kind = case is_rec of
-            Recursive -> mkBoxedTypeKind       -- Recursive, so no unboxed types
-            NonRecursive -> mkTypeKind         -- Non-recursive, so we permit unboxed types
-\end{code}
+    names = collectPatBinders pat
 
-Polymorphic recursion
-~~~~~~~~~~~~~~~~~~~~~
-The game plan for polymorphic recursion in the code above is 
 
-       * Bind any variable for which we have a type signature
-         to an Id with a polymorphic type.  Then when type-checking 
-         the RHSs we'll make a full polymorphic call.
+tcLhs sig_fn other_bind = pprPanic "tcLhs" (ppr other_bind)
+       -- AbsBind, VarBind impossible
 
-This fine, but if you aren't a bit careful you end up with a horrendous
-amount of partial application and (worse) a huge space leak. For example:
+-------------------
+tcRhs :: TcMonoBind -> TcM (HsBind TcId)
+tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches)
+  = do { (co_fn, matches') <- tcMatchesFun (idName mono_id) matches 
+                                           (idType mono_id)
+       ; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches',
+                           bind_fvs = placeHolderNames, fun_co_fn = co_fn }) }
 
-       f :: Eq a => [a] -> [a]
-       f xs = ...f...
+tcRhs bind@(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 }) }
 
-If we don't take care, after typechecking we get
 
-       f = /\a -> \d::Eq a -> let f' = f a d
-                              in
-                              \ys:[a] -> ...f'...
+---------------------
+getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
+getMonoBindInfo tc_binds
+  = foldr (get_info . unLoc) [] tc_binds
+  where
+    get_info (TcFunBind info _ _ _)  rest = info : rest
+    get_info (TcPatBind infos _ _ _) rest = infos ++ rest
+\end{code}
 
-Notice the the stupid construction of (f a d), which is of course
-identical to the function we're executing.  In this case, the
-polymorphic recursion ins't being used (but that's a very common case).
 
-This can lead to a massive space leak, from the following top-level defn:
+%************************************************************************
+%*                                                                     *
+               Generalisation
+%*                                                                     *
+%************************************************************************
 
-       ff :: [Int] -> [Int]
-       ff = f dEqInt
+\begin{code}
+generalise :: TopLevelFlag -> Bool 
+          -> [MonoBindInfo] -> [Inst]
+          -> TcM ([TcTyVar], TcDictBinds, [TcId])
+generalise top_lvl is_unrestricted mono_infos lie_req
+  | not is_unrestricted        -- 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
+       ; 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
+
+       -- Check that the needed dicts can be
+       -- expressed in terms of the signature ones
+       ; (forall_tvs, dict_binds) <- tcSimplifyInferCheck doc tau_tvs sig_avails lie_req
+       
+       -- Check that signature type variables are OK
+       ; final_qtvs <- checkSigsTyVars forall_tvs sigs
 
-Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
-f' is another thunk which evaluates to the same thing... and you end
-up with a chain of identical values all hung onto by the CAF ff.
+       ; returnM (final_qtvs, dict_binds, map instToId sig_lie) }
+  where
+    bndrs   = bndrNames mono_infos
+    sigs    = [sig | (_, Just sig, _) <- mono_infos]
+    tau_tvs = foldr (unionVarSet . exactTyVarsOfType . getMonoType) emptyVarSet mono_infos
+               -- NB: exactTyVarsOfType; see Note [Silly type synonym] 
+               --     near defn of TcType.exactTyVarsOfType
+    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 mono_id poly_id (mkTyVarTys tvs) theta loc
+\end{code}
 
-Solution: when typechecking the RHSs we always have in hand the
-*monomorphic* Ids for each binding.  So we just need to make sure that
-if (Method f a d) shows up in the constraints emerging from (...f...)
-we just use the monomorphic Id.  We achieve this by adding monomorphic Ids
-to the "givens" when simplifying constraints.  Thats' what the "mono_lies"
-is doing.
+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).
 
+The trick here is that all the signatures should have the same
+context, and we want to share type variables for that context, so that
+all the right hand sides agree a common vocabulary for their type
+constraints
 
-%************************************************************************
-%*                                                                     *
-\subsection{getTyVarsToGen}
-%*                                                                     *
-%************************************************************************
+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 (sig1 : sigs)       -- Argument is always non-empty
+  = do { mapM unify_ctxt sigs
+       ; newDictsAtLoc (sig_loc sig1) (sig_theta sig1) }
+  where
+    theta1 = sig_theta sig1
+    unify_ctxt :: TcSigInfo -> TcM ()
+    unify_ctxt sig@(TcSigInfo { sig_theta = theta })
+       = setSrcSpan (instLocSrcSpan (sig_loc sig))     $
+         addErrCtxt (sigContextsCtxt sig1 sig)         $
+         unifyTheta theta1 theta
+
+checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
+checkSigsTyVars qtvs sigs 
+  = do { gbl_tvs <- tcGetGlobalTyVars
+       ; sig_tvs_s <- mappM (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)
+       ; returnM 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
+          ; ifM (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)
 
-@getTyVarsToGen@ decides what type variables generalise over.
+    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) }
+       where
+\end{code}    
+
+
+@getTyVarsToGen@ decides what type variables to generalise over.
 
 For a "restricted group" -- see the monomorphism restriction
 for a definition -- we bind no dictionaries, and
@@ -467,6 +859,8 @@ generalise.  We must be careful about doing this:
        Another, more common, example is when there's a Method inst in
        the LIE, whose type might very well involve non-overloaded
        type variables.
+  [NOTE: Jan 2001: I don't understand the problem here so I'm doing 
+       the simple thing instead]
 
  (b) On the other hand, we mustn't generalise tyvars which are constrained,
        because we are going to pass on out the unmodified LIE, with those
@@ -476,486 +870,210 @@ So we are careful, and do a complete simplification just to find the
 constrained tyvars. We don't use any of the results, except to
 find which tyvars are constrained.
 
-\begin{code}
-getTyVarsToGen is_unrestricted mono_id_tys lie
-  = tcGetGlobalTyVars                  `thenNF_Tc` \ free_tyvars ->
-    zonkTcTypes mono_id_tys            `thenNF_Tc` \ zonked_mono_id_tys ->
-    let
-       tyvars_to_gen = tyVarsOfTypes zonked_mono_id_tys `minusTyVarSet` free_tyvars
-    in
-    if is_unrestricted
-    then
-       returnTc (emptyTyVarSet, tyvars_to_gen)
-    else
-       tcSimplify (text "getTVG") NotTopLevel tyvars_to_gen lie    `thenTc` \ (_, _, constrained_dicts) ->
-       let
-         -- ASSERT: dicts_sig is already zonked!
-           constrained_tyvars    = foldrBag (unionTyVarSets . tyVarsOfInst) emptyTyVarSet constrained_dicts
-           reduced_tyvars_to_gen = tyvars_to_gen `minusTyVarSet` constrained_tyvars
-        in
-        returnTc (constrained_tyvars, reduced_tyvars_to_gen)
-\end{code}
-
-
-\begin{code}
-isUnRestrictedGroup :: [Name]          -- Signatures given for these
-                   -> RenamedMonoBinds
-                   -> Bool
-
-is_elem v vs = isIn "isUnResMono" v vs
-
-isUnRestrictedGroup sigs (PatMonoBind (VarPatIn v) _ _) = v `is_elem` sigs
-isUnRestrictedGroup sigs (PatMonoBind other      _ _)  = False
-isUnRestrictedGroup sigs (VarMonoBind v _)             = v `is_elem` sigs
-isUnRestrictedGroup sigs (FunMonoBind _ _ _ _)         = True
-isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2)                = isUnRestrictedGroup sigs mb1 &&
-                                                         isUnRestrictedGroup sigs mb2
-isUnRestrictedGroup sigs EmptyMonoBinds                        = True
-\end{code}
-
-@defaultUncommittedTyVar@ checks for generalisation over unboxed
-types, and defaults any TypeKind TyVars to BoxedTypeKind.
-
-\begin{code}
-defaultUncommittedTyVar tyvar
-  | isTypeKind (tyVarKind tyvar)
-  = newTcTyVar mkBoxedTypeKind                                 `thenNF_Tc` \ boxed_tyvar ->
-    unifyTauTy (mkTyVarTy boxed_tyvar) (mkTyVarTy tyvar)       `thenTc_`
-    returnTc boxed_tyvar
-
-  | otherwise
-  = returnTc tyvar
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
-\subsection{tcMonoBind}
-%*                                                                     *
-%************************************************************************
-
-@tcMonoBinds@ deals with a single @MonoBind@.  
-The signatures have been dealt with already.
-
-\begin{code}
-tcMonoBinds :: RenamedMonoBinds 
-           -> [Name] -> [TcIdBndr s]
-           -> [TcSigInfo s]
-           -> TcM s (TcMonoBinds s, LIE s)
-
-tcMonoBinds mbind binder_names mono_ids tc_ty_sigs
-  = tcExtendLocalValEnv binder_names mono_ids (
-       tc_mono_binds mbind
-    )
-  where
-    sig_names = [name | (TySigInfo name _ _ _ _ _) <- tc_ty_sigs]
-    sig_ids   = [id   | (TySigInfo _   id _ _ _ _) <- tc_ty_sigs]
-
-    tc_mono_binds EmptyMonoBinds = returnTc (EmptyMonoBinds, emptyLIE)
-
-    tc_mono_binds (AndMonoBinds mb1 mb2)
-      = tc_mono_binds mb1              `thenTc` \ (mb1a, lie1) ->
-        tc_mono_binds mb2              `thenTc` \ (mb2a, lie2) ->
-        returnTc (AndMonoBinds mb1a mb2a, lie1 `plusLIE` lie2)
-
-    tc_mono_binds (FunMonoBind name inf matches locn)
-      = tcAddSrcLoc locn                               $
-       tcLookupLocalValueOK "tc_mono_binds" name       `thenNF_Tc` \ id ->
-
-               -- Before checking the RHS, extend the envt with
-               -- bindings for the *polymorphic* Ids from any type signatures
-       tcExtendLocalValEnv sig_names sig_ids           $
-       tcMatchesFun name (idType id) matches           `thenTc` \ (matches', lie) ->
-
-       returnTc (FunMonoBind (TcId id) inf matches' locn, lie)
-
-    tc_mono_binds bind@(PatMonoBind pat grhss_and_binds locn)
-      = tcAddSrcLoc locn                       $
-       tcAddErrCtxt (patMonoBindsCtxt bind)    $
-       tcPat pat                               `thenTc` \ (pat2, lie_pat, pat_ty) ->
-
-               -- Before checking the RHS, but after the pattern, extend the envt with
-               -- bindings for the *polymorphic* Ids from any type signatures
-       tcExtendLocalValEnv sig_names sig_ids   $
-       tcGRHSsAndBinds pat_ty grhss_and_binds  `thenTc` \ (grhss_and_binds2, lie) ->
-       returnTc (PatMonoBind pat2 grhss_and_binds2 locn,
-                 plusLIE lie_pat lie)
-\end{code}
-
-%************************************************************************
-%*                                                                     *
-\subsection{Signatures}
-%*                                                                     *
-%************************************************************************
-
-@tcSigs@ checks the signatures for validity, and returns a list of
-{\em freshly-instantiated} signatures.  That is, the types are already
-split up, and have fresh type variables installed.  All non-type-signature
-"RenamedSigs" are ignored.
-
-The @TcSigInfo@ contains @TcTypes@ because they are unified with
-the variable's type, and after that checked to see whether they've
-been instantiated.
-
-\begin{code}
-data TcSigInfo s
-  = TySigInfo      
-       Name                    -- N, the Name in corresponding binding
-       (TcIdBndr s)            -- *Polymorphic* binder for this value...
-                               -- Usually has name = N, but doesn't have to.
-       [TcTyVar s]
-       (TcThetaType s)
-       (TcTauType s)
-       SrcLoc
-
-
-maybeSig :: [TcSigInfo s] -> Name -> Maybe (TcSigInfo s)
-       -- Search for a particular signature
-maybeSig [] name = Nothing
-maybeSig (sig@(TySigInfo sig_name _ _ _ _ _) : sigs) name
-  | name == sig_name = Just sig
-  | otherwise       = maybeSig sigs name
-\end{code}
-
-
-\begin{code}
-tcTySig :: (Name -> PragmaInfo)
-       -> RenamedSig
-       -> TcM s (TcSigInfo s)
-
-tcTySig prag_info_fn (Sig v ty src_loc)
- = tcAddSrcLoc src_loc $
-   tcHsType ty                 `thenTc` \ sigma_ty ->
-
-       -- Convert from Type to TcType  
-   tcInstSigType sigma_ty      `thenNF_Tc` \ sigma_tc_ty ->
-   let
-     poly_id = mkUserId v sigma_tc_ty (prag_info_fn v)
-   in
-       -- Instantiate this type
-       -- It's important to do this even though in the error-free case
-       -- we could just split the sigma_tc_ty (since the tyvars don't
-       -- unified with anything).  But in the case of an error, when
-       -- the tyvars *do* get unified with something, we want to carry on
-       -- typechecking the rest of the program with the function bound
-       -- to a pristine type, namely sigma_tc_ty
-   tcInstSigTcType sigma_tc_ty `thenNF_Tc` \ (tyvars, rho) ->
-   let
-     (theta, tau) = splitRhoTy rho
-       -- This splitSigmaTy tries hard to make sure that tau' is a type synonym
-       -- wherever possible, which can improve interface files.
-   in
-   returnTc (TySigInfo v poly_id tyvars theta tau src_loc)
-\end{code}
-
-@checkSigMatch@ does the next step in checking signature matching.
-The tau-type part has already been unified.  What we do here is to
-check that this unification has not over-constrained the (polymorphic)
-type variables of the original signature type.
-
-The error message here is somewhat unsatisfactory, but it'll do for
-now (ToDo).
-
-\begin{code}
-checkSigMatch []
-  = returnTc (error "checkSigMatch")
-
-checkSigMatch tc_ty_sigs@( sig1@(TySigInfo _ id1 _ theta1 _ _) : all_sigs_but_first )
-  =    -- CHECK THAT THE SIGNATURE TYVARS AND TAU_TYPES ARE OK
-       -- Doesn't affect substitution
-    mapTc check_one_sig tc_ty_sigs     `thenTc_`
+Note [Polymorphic recursion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The game plan for polymorphic recursion in the code above is 
 
-       -- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
-       -- The type signatures on a mutually-recursive group of definitions
-       -- must all have the same context (or none).
-       --
-       -- We unify them because, with polymorphic recursion, their types
-       -- might not otherwise be related.  This is a rather subtle issue.
-       -- ToDo: amplify
-    mapTc check_one_cxt all_sigs_but_first             `thenTc_`
+       * Bind any variable for which we have a type signature
+         to an Id with a polymorphic type.  Then when type-checking 
+         the RHSs we'll make a full polymorphic call.
 
-    returnTc theta1
-  where
-    sig1_dict_tys      = mk_dict_tys theta1
-    n_sig1_dict_tys    = length sig1_dict_tys
-
-    check_one_cxt sig@(TySigInfo _ id _  theta _ src_loc)
-       = tcAddSrcLoc src_loc   $
-        tcAddErrCtxt (sigContextsCtxt id1 id) $
-        checkTc (length this_sig_dict_tys == n_sig1_dict_tys)
-                               sigContextsErr          `thenTc_`
-        unifyTauTyLists sig1_dict_tys this_sig_dict_tys
-      where
-        this_sig_dict_tys = mk_dict_tys theta
-
-    check_one_sig (TySigInfo name id sig_tyvars _ sig_tau src_loc)
-      = tcAddSrcLoc src_loc    $
-       tcAddErrCtxt (sigCtxt id) $
-       checkSigTyVars sig_tyvars sig_tau
-
-    mk_dict_tys theta = [mkDictTy c ts | (c,ts) <- theta]
-\end{code}
+This fine, but if you aren't a bit careful you end up with a horrendous
+amount of partial application and (worse) a huge space leak. For example:
 
+       f :: Eq a => [a] -> [a]
+       f xs = ...f...
 
-@checkSigTyVars@ is used after the type in a type signature has been unified with
-the actual type found.  It then checks that the type variables of the type signature
-are
-       (a) still all type variables
-               eg matching signature [a] against inferred type [(p,q)]
-               [then a will be unified to a non-type variable]
+If we don't take care, after typechecking we get
 
-       (b) still all distinct
-               eg matching signature [(a,b)] against inferred type [(p,p)]
-               [then a and b will be unified together]
+       f = /\a -> \d::Eq a -> let f' = f a d
+                              in
+                              \ys:[a] -> ...f'...
 
-       (c) not mentioned in the environment
-               eg the signature for f in this:
+Notice the the stupid construction of (f a d), which is of course
+identical to the function we're executing.  In this case, the
+polymorphic recursion isn't being used (but that's a very common case).
+This can lead to a massive space leak, from the following top-level defn
+(post-typechecking)
 
-                       g x = ... where
-                                       f :: a->[a]
-                                       f y = [x,y]
+       ff :: [Int] -> [Int]
+       ff = f Int dEqInt
 
-               Here, f is forced to be monorphic by the free occurence of x.
+Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
+f' is another thunk which evaluates to the same thing... and you end
+up with a chain of identical values all hung onto by the CAF ff.
 
-Before doing this, the substitution is applied to the signature type variable.
+       ff = f Int dEqInt
 
-We used to have the notion of a "DontBind" type variable, which would
-only be bound to itself or nothing.  Then points (a) and (b) were 
-self-checking.  But it gave rise to bogus consequential error messages.
-For example:
+          = let f' = f Int dEqInt in \ys. ...f'...
 
-   f = (*)     -- Monomorphic
+          = let f' = let f' = f Int dEqInt in \ys. ...f'...
+                     in \ys. ...f'...
 
-   g :: Num a => a -> a
-   g x = f x x
+Etc.
 
-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 x) context arising from f's definition;
-we try to unify x with Int (to default it), but find that x has already
-been unified with the DontBind variable "a" from g's signature.
-This is really a problem with side-effecting unification; we'd like to
-undo g's effects when its type signature fails, but unification is done
-by side effect, so we can't (easily).
+NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),
+which would make the space leak go away in this case
 
-So we revert to ordinary type variables for signatures, and try to
-give a helpful message in checkSigTyVars.
+Solution: when typechecking the RHSs we always have in hand the
+*monomorphic* Ids for each binding.  So we just need to make sure that
+if (Method f a d) shows up in the constraints emerging from (...f...)
+we just use the monomorphic Id.  We achieve this by adding monomorphic Ids
+to the "givens" when simplifying constraints.  That's what the "lies_avail"
+is doing.
 
-\begin{code}
-checkSigTyVars :: [TcTyVar s]          -- The original signature type variables
-              -> TcType s              -- signature type (for err msg)
-              -> TcM s [TcTyVar s]     -- Zonked signature type variables
-
-checkSigTyVars sig_tyvars sig_tau
-  = mapNF_Tc zonkTcTyVar sig_tyvars    `thenNF_Tc` \ sig_tys ->
-    let
-       sig_tyvars' = map (getTyVar "checkSigTyVars") sig_tys
-    in
+Then we get
 
-       -- Check points (a) and (b)
-    checkTcM (all isTyVarTy sig_tys && hasNoDups sig_tyvars')
-            (zonkTcType sig_tau        `thenNF_Tc` \ sig_tau' ->
-             failWithTc (badMatchErr sig_tau sig_tau')
-            )                          `thenTc_`
-
-       -- Check point (c)
-       -- We want to report errors in terms of the original signature tyvars,
-       -- ie sig_tyvars, NOT sig_tyvars'.  sig_tyvars' correspond
-       -- 1-1 with sig_tyvars, so we can just map back.
-    tcGetGlobalTyVars                  `thenNF_Tc` \ globals ->
-    let
-       mono_tyvars' = [sig_tv' | sig_tv' <- sig_tyvars', 
-                                 sig_tv' `elementOfTyVarSet` globals]
-
-       mono_tyvars = map (assoc "checkSigTyVars" (sig_tyvars' `zip` sig_tyvars)) mono_tyvars'
-    in
-    checkTcM (null mono_tyvars')
-            (failWithTc (notAsPolyAsSigErr sig_tau mono_tyvars))       `thenTc_`
+       f = /\a -> \d::Eq a -> letrec
+                                fm = \ys:[a] -> ...fm...
+                              in
+                              fm
 
-    returnTc sig_tyvars'
-\end{code}
 
 
 %************************************************************************
 %*                                                                     *
-\subsection{SPECIALIZE pragmas}
+               Signatures
 %*                                                                     *
 %************************************************************************
 
+Type signatures are tricky.  See Note [Signature skolems] in TcType
 
-@tcPragmaSigs@ munches up the "signatures" that arise through *user*
-pragmas.  It is convenient for them to appear in the @[RenamedSig]@
-part of a binding because then the same machinery can be used for
-moving them into place as is done for type signatures.
+@tcSigs@ checks the signatures for validity, and returns a list of
+{\em freshly-instantiated} signatures.  That is, the types are already
+split up, and have fresh type variables installed.  All non-type-signature
+"RenamedSigs" are ignored.
+
+The @TcSigInfo@ contains @TcTypes@ because they are unified with
+the variable's type, and after that checked to see whether they've
+been instantiated.
 
 \begin{code}
-tcPragmaSigs :: [RenamedSig]                   -- The pragma signatures
-            -> TcM s (Name -> PragmaInfo,      -- Maps name to the appropriate PragmaInfo
-                      TcMonoBinds s,
-                      LIE s)
+type TcSigFun = Name -> Maybe (LSig Name)
 
--- For now we just deal with INLINE pragmas
-tcPragmaSigs sigs = returnTc (prag_fn, EmptyMonoBinds, emptyLIE )
+mkSigFun :: [LSig Name] -> TcSigFun
+-- Search for a particular type signature
+-- Precondition: the sigs are all type sigs
+-- Precondition: no duplicates
+mkSigFun sigs = lookupNameEnv env
   where
-    prag_fn name | any has_inline sigs = IWantToBeINLINEd
-                | otherwise           = NoPragmaInfo
-                where
-                   has_inline (InlineSig n _) = (n == name)
-                   has_inline other           = False
-               
-
-{- 
-tcPragmaSigs sigs
-  = mapAndUnzip3Tc tcPragmaSig sigs    `thenTc` \ (names_w_id_infos, binds, lies) ->
-    let
-       name_to_info name = foldr ($) noIdInfo
-                                 [info_fn | (n,info_fn) <- names_w_id_infos, n==name]
-    in
-    returnTc (name_to_info,
-             foldr ThenBinds EmptyBinds binds,
-             foldr plusLIE emptyLIE lies)
-\end{code}
-
-Here are the easy cases for tcPragmaSigs
-
-\begin{code}
-tcPragmaSig (InlineSig name loc)
-  = returnTc ((name, addUnfoldInfo (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE)
-tcPragmaSig (MagicUnfoldingSig name string loc)
-  = returnTc ((name, addUnfoldInfo (mkMagicUnfolding string)), EmptyBinds, emptyLIE)
+    env = mkNameEnv [(expectJust "mkSigFun" (sigName sig), sig) | sig <- sigs]
+
+---------------
+data TcSigInfo
+  = TcSigInfo {
+       sig_id     :: TcId,             --  *Polymorphic* binder for this value...
+
+       sig_scoped :: [Name],           -- Names for any scoped type variables
+                                       -- Invariant: correspond 1-1 with an initial
+                                       -- segment of sig_tvs (see Note [Scoped])
+
+       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 [Scoped]
+-- There may be more instantiated type variables than scoped 
+-- ones.  For example:
+--     type T a = forall b. b -> (a,b)
+--     f :: forall c. T c
+-- Here, the signature for f will have one scoped type variable, c,
+-- 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 sig_scoped
+
+--     Note [Instantiate sig]
+-- It's vital to instantiate a type signature with fresh variable.
+-- 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}
 
-The interesting case is for SPECIALISE pragmas.  There are two forms.
-Here's the first form:
-\begin{verbatim}
-       f :: Ord a => [a] -> b -> b
-       {-# SPECIALIZE f :: [Int] -> b -> b #-}
-\end{verbatim}
-
-For this we generate:
-\begin{verbatim}
-       f* = /\ b -> let d1 = ...
-                    in f Int b d1
-\end{verbatim}
-
-where f* is a SpecPragmaId.  The **sole** purpose of SpecPragmaIds is to
-retain a right-hand-side that the simplifier will otherwise discard as
-dead code... the simplifier has a flag that tells it not to discard
-SpecPragmaId bindings.
-
-In this case the f* retains a call-instance of the overloaded
-function, f, (including appropriate dictionaries) so that the
-specialiser will subsequently discover that there's a call of @f@ at
-Int, and will create a specialisation for @f@.  After that, the
-binding for @f*@ can be discarded.
-
-The second form is this:
-\begin{verbatim}
-       f :: Ord a => [a] -> b -> b
-       {-# SPECIALIZE f :: [Int] -> b -> b = g #-}
-\end{verbatim}
-
-Here @g@ is specified as a function that implements the specialised
-version of @f@.  Suppose that g has type (a->b->b); that is, g's type
-is more general than that required.  For this we generate
-\begin{verbatim}
-       f@Int = /\b -> g Int b
-       f* = f@Int
-\end{verbatim}
-
-Here @f@@Int@ is a SpecId, the specialised version of @f@.  It inherits
-f's export status etc.  @f*@ is a SpecPragmaId, as before, which just serves
-to prevent @f@@Int@ from being discarded prematurely.  After specialisation,
-if @f@@Int@ is going to be used at all it will be used explicitly, so the simplifier can
-discard the f* binding.
-
-Actually, there is really only point in giving a SPECIALISE pragma on exported things,
-and the simplifer won't discard SpecIds for exporte things anyway, so maybe this is
-a bit of overkill.
-
 \begin{code}
-tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
-  = tcAddSrcLoc src_loc                                $
-    tcAddErrCtxt (valSpecSigCtxt name spec_ty) $
-
-       -- Get and instantiate its alleged specialised type
-    tcHsType poly_ty                           `thenTc` \ sig_sigma ->
-    tcInstSigType  sig_sigma                   `thenNF_Tc` \ sig_ty ->
-    let
-       (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
-       origin = ValSpecOrigin name
-    in
-
-       -- Check that the SPECIALIZE pragma had an empty context
-    checkTc (null sig_theta)
-           (panic "SPECIALIZE non-empty context (ToDo: msg)") `thenTc_`
-
-       -- Get and instantiate the type of the id mentioned
-    tcLookupLocalValueOK "tcPragmaSig" name    `thenNF_Tc` \ main_id ->
-    tcInstSigType [] (idType main_id)          `thenNF_Tc` \ main_ty ->
-    let
-       (main_tyvars, main_rho) = splitForAllTys main_ty
-       (main_theta,main_tau)   = splitRhoTy main_rho
-       main_arg_tys            = mkTyVarTys main_tyvars
-    in
-
-       -- Check that the specialised type is indeed an instance of
-       -- the type of the main function.
-    unifyTauTy sig_tau main_tau                `thenTc_`
-    checkSigTyVars sig_tyvars sig_tau  `thenTc_`
-
-       -- Check that the type variables of the polymorphic function are
-       -- either left polymorphic, or instantiate to ground type.
-       -- Also check that the overloaded type variables are instantiated to
-       -- ground type; or equivalently that all dictionaries have ground type
-    zonkTcTypes main_arg_tys           `thenNF_Tc` \ main_arg_tys' ->
-    zonkTcThetaType main_theta         `thenNF_Tc` \ main_theta' ->
-    tcAddErrCtxt (specGroundnessCtxt main_arg_tys')
-             (checkTc (all isGroundOrTyVarTy main_arg_tys'))           `thenTc_`
-    tcAddErrCtxt (specContextGroundnessCtxt main_theta')
-             (checkTc (and [isGroundTy ty | (_,ty) <- theta']))        `thenTc_`
-
-       -- Build the SpecPragmaId; it is the thing that makes sure we
-       -- don't prematurely dead-code-eliminate the binding we are really interested in.
-    newSpecPragmaId name sig_ty                `thenNF_Tc` \ spec_pragma_id ->
-
-       -- Build a suitable binding; depending on whether we were given
-       -- a value (Maybe Name) to be used as the specialisation.
-    case using of
-      Nothing ->               -- No implementation function specified
-
-               -- Make a Method inst for the occurrence of the overloaded function
-       newMethodWithGivenTy (OccurrenceOf name)
-                 (TcId main_id) main_arg_tys main_rho  `thenNF_Tc` \ (lie, meth_id) ->
-
-       let
-           pseudo_bind = VarMonoBind spec_pragma_id pseudo_rhs
-           pseudo_rhs  = mkHsTyLam sig_tyvars (HsVar (TcId meth_id))
-       in
-       returnTc (pseudo_bind, lie, \ info -> info)
-
-      Just spec_name ->                -- Use spec_name as the specialisation value ...
-
-               -- Type check a simple occurrence of the specialised Id
-       tcId spec_name          `thenTc` \ (spec_body, spec_lie, spec_tau) ->
-
-               -- Check that it has the correct type, and doesn't constrain the
-               -- signature variables at all
-       unifyTauTy sig_tau spec_tau             `thenTc_`
-       checkSigTyVars sig_tyvars sig_tau       `thenTc_`
-
-           -- Make a local SpecId to bind to applied spec_id
-       newSpecId main_id main_arg_tys sig_ty   `thenNF_Tc` \ local_spec_id ->
-
-       let
-           spec_rhs   = mkHsTyLam sig_tyvars spec_body
-           spec_binds = VarMonoBind local_spec_id spec_rhs
-                          `AndMonoBinds`
-                        VarMonoBind spec_pragma_id (HsVar (TcId local_spec_id))
-           spec_info  = SpecInfo spec_tys (length main_theta) local_spec_id
-       in
-       returnTc ((name, addSpecInfo spec_info), spec_binds, spec_lie)
--}
+tcTySig :: LSig Name -> TcM TcId
+tcTySig (L span (TypeSig (L _ name) ty))
+  = setSrcSpan span            $
+    do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
+       ; return (mkLocalId name sigma_ty) }
+
+-------------------
+tcInstSig_maybe :: Maybe (LSig Name) -> TcM (Maybe TcSigInfo)
+-- Instantiate with *meta* type variables; 
+-- this signature is part of a multi-signature group
+tcInstSig_maybe Nothing    = return Nothing
+tcInstSig_maybe (Just sig) = do { tc_sig <- tcInstSig False sig
+                               ; return (Just tc_sig) }
+
+tcInstSig :: Bool -> LSig Name -> TcM TcSigInfo
+-- Instantiate the signature, with either skolems or meta-type variables
+-- depending on the use_skols boolean
+--
+-- We always instantiate with freshs uniques,
+-- although we keep the same print-name
+--     
+--     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!!
+
+tcInstSig use_skols (L loc (TypeSig (L _ name) hs_ty))
+  = setSrcSpan loc $
+    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)
+             inst_tyvars | use_skols = tcInstSkolTyVars skol_info
+                         | otherwise = tcInstSigTyVars  skol_info
+       ; (tvs, theta, tau) <- tcInstType inst_tyvars (idType poly_id)
+       ; loc <- getInstLoc (SigOrigin skol_info)
+       ; return (TcSigInfo { sig_id = poly_id,
+                             sig_tvs = tvs, sig_theta = theta, sig_tau = tau, 
+                             sig_scoped = scoped_names, sig_loc = loc }) }
+               -- Note that the scoped_names and the sig_tvs will have
+               -- different Names. That's quite ok; when we bring the 
+               -- scoped_names into scope, we just bind them to the sig_tvs
+  where
+       -- 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 [Scoped] with TcSigInfo.)
+       -- We also only have scoped type variables when we are instantiating
+       -- with true skolems
+    scoped_names = case (use_skols, hs_ty) of
+                    (True, L _ (HsForAllTy Explicit tvs _ _)) -> hsLTyVarNames tvs
+                    other                                     -> []
+
+-------------------
+isUnRestrictedGroup :: [LHsBind Name] -> TcSigFun -> TcM Bool
+isUnRestrictedGroup binds sig_fn
+  = do { mono_restriction <- doptM Opt_MonomorphismRestriction
+       ; return (not mono_restriction || all_unrestricted) }
+  where 
+    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_match (MatchGroup (L _ (Match [] _ _) : _) _) = False
+       -- No args => like a pattern binding
+    unrestricted_match other             = True
+       -- Some args => a function binding
 \end{code}
 
 
@@ -967,66 +1085,33 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
 
 
 \begin{code}
-patMonoBindsCtxt bind
-  = hang (ptext SLIT("In a pattern binding:")) 4 (ppr bind)
-
------------------------------------------------
-valSpecSigCtxt v ty
-  = sep [ptext SLIT("In a SPECIALIZE pragma for a value:"),
-        nest 4 (ppr v <+> ptext SLIT(" ::") <+> ppr ty)]
+-- This one is called on LHS, when pat and grhss are both Name 
+-- and on RHS, when pat is TcId and grhss is still Name
+patMonoBindsCtxt pat grhss
+  = hang (ptext SLIT("In a pattern binding:")) 4 (pprPatBind pat grhss)
 
 -----------------------------------------------
-notAsPolyAsSigErr sig_tau mono_tyvars
-  = hang (ptext SLIT("A type signature is more polymorphic than the inferred type"))
-       4  (vcat [text "Can't for-all the type variable(s)" <+> 
-                 pprQuotedList mono_tyvars,
-                 text "in the type" <+> quotes (ppr sig_tau)
-          ])
+sigContextsCtxt sig1 sig2
+  = vcat [ptext SLIT("When matching the contexts of the signatures for"), 
+         nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1),
+                       ppr id2 <+> dcolon <+> ppr (idType id2)]),
+         ptext SLIT("The signature contexts in a mutually recursive group should all be identical")]
+  where
+    id1 = sig_id sig1
+    id2 = sig_id sig2
 
------------------------------------------------
-badMatchErr sig_ty inferred_ty
-  = hang (ptext SLIT("Type signature doesn't match inferred type"))
-        4 (vcat [hang (ptext SLIT("Signature:")) 4 (ppr sig_ty),
-                     hang (ptext SLIT("Inferred :")) 4 (ppr inferred_ty)
-          ])
 
 -----------------------------------------------
-sigCtxt id 
-  = sep [ptext SLIT("When checking the type signature for"), quotes (ppr id)]
-
-bindSigsCtxt ids
-  = ptext SLIT("When checking the type signature(s) for") <+> pprQuotedList ids
+unboxedTupleErr name ty
+  = hang (ptext SLIT("Illegal binding of unboxed tuple"))
+        4 (ppr name <+> dcolon <+> ppr ty)
 
 -----------------------------------------------
-sigContextsErr
-  = ptext SLIT("Mismatched contexts")
-sigContextsCtxt s1 s2
-  = hang (hsep [ptext SLIT("When matching the contexts of the signatures for"), 
-               quotes (ppr s1), ptext SLIT("and"), quotes (ppr s2)])
-        4 (ptext SLIT("(the signature contexts in a mutually recursive group should all be identical)"))
+restrictedBindCtxtErr binder_names
+  = hang (ptext SLIT("Illegal overloaded type signature(s)"))
+       4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names,
+               ptext SLIT("that falls under the monomorphism restriction")])
 
------------------------------------------------
-specGroundnessCtxt
-  = panic "specGroundnessCtxt"
-
---------------------------------------------
-specContextGroundnessCtxt -- err_ctxt dicts
-  = panic "specContextGroundnessCtxt"
-{-
-  = hang (
-       sep [hsep [ptext SLIT("In the SPECIALIZE pragma for"), ppr name],
-            hcat [ptext SLIT(" specialised to the type"), ppr spec_ty],
-            pp_spec_id,
-            ptext SLIT("... not all overloaded type variables were instantiated"),
-            ptext SLIT("to ground types:")])
-      4 (vcat [hsep [ppr c, ppr t]
-                 | (c,t) <- map getDictClassAndType dicts])
-  where
-    (name, spec_ty, locn, pp_spec_id)
-      = case err_ctxt of
-         ValSpecSigCtxt    n ty loc      -> (n, ty, loc, \ x -> empty)
-         ValSpecSpecIdCtxt n ty spec loc ->
-           (n, ty, loc,
-            hsep [ptext SLIT("... type of explicit id"), ppr spec])
--}
+genCtxt binder_names
+  = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names
 \end{code}