[project @ 2004-12-22 16:58:34 by simonpj]

----------------------------------------
	     Add more scoped type variables
	----------------------------------------

Now the top-level forall'd variables of a type signature scope
over the right hand side of that function.

	f :: a -> a
	f x = ....

The type variable 'a' is in scope in the RHS, and in f's patterns.

It's implied by -fglasgow-exts, but can also be switched off independently
using -fscoped-type-variables (and the -fno variant)

ghc/compiler/iface/TcIface.lhs

@@ -29,7 +29,7 @@ import HscTypes		( ExternalPackageState(..), EpsStats(..), PackageInstEnv,
 			  ModIface(..), ModDetails(..), ModGuts,
 			  mkTypeEnv, extendTypeEnv, 
 			  lookupTypeEnv, lookupType, typeEnvIds )
-import InstEnv		( extendInstEnv )
+import InstEnv		( extendInstEnvList )
 import CoreSyn
 import PprCore		( pprIdRules )
 import Rules		( extendRuleBaseList )
@@ -436,7 +436,7 @@ loadImportedInsts cls tys
 	-- And put them in the package instance environment
 	; updateEps ( \ eps ->
 	    let 
-		inst_env' = foldl extendInstEnv (eps_inst_env eps) dfuns
+		inst_env' = extendInstEnvList (eps_inst_env eps) dfuns
 	    in
 	    (eps { eps_inst_env = inst_env' }, inst_env')
 	)}}

ghc/compiler/main/CmdLineOpts.lhs

@@ -275,6 +275,7 @@ data DynFlag
    | Opt_ImplicitParams
    | Opt_Generics
    | Opt_ImplicitPrelude 
+   | Opt_ScopedTypeVariables
 
    -- optimisation opts
    | Opt_Strictness

ghc/compiler/main/DriverFlags.hs

@@ -467,6 +467,7 @@ fFlags = [
   ( "parr",				Opt_PArr ),
   ( "th",				Opt_TH ),
   ( "implicit-prelude",  		Opt_ImplicitPrelude ),
+  ( "scoped-type-variables",  		Opt_ScopedTypeVariables ),
   ( "monomorphism-restriction",		Opt_MonomorphismRestriction ),
   ( "implicit-params",			Opt_ImplicitParams ),
   ( "allow-overlapping-instances", 	Opt_AllowOverlappingInstances ),
@@ -485,7 +486,7 @@ fFlags = [
   ( "unbox-strict-fields",		Opt_UnboxStrictFields )
   ]
 
-glasgowExtsFlags = [ Opt_GlasgowExts, Opt_FFI, Opt_TH, Opt_ImplicitParams ]
+glasgowExtsFlags = [ Opt_GlasgowExts, Opt_FFI, Opt_TH, Opt_ImplicitParams, Opt_ScopedTypeVariables ]
 
 isFFlag f = f `elem` (map fst fFlags)
 getFFlag f = fromJust (lookup f fFlags)

ghc/compiler/main/HscTypes.lhs

@@ -92,7 +92,6 @@ import Maybes		( orElse )
 import Outputable
 import SrcLoc		( SrcSpan )
 import UniqSupply	( UniqSupply )
-import Maybe		( fromJust )
 import FastString	( FastString )
 
 import DATA_IOREF	( IORef, readIORef )

ghc/compiler/rename/RnBinds.lhs

@@ -27,7 +27,7 @@ import RnExpr		( rnMatchGroup, rnMatch, rnGRHSs, checkPrecMatch )
 import RnEnv		( bindLocatedLocalsRn, lookupLocatedBndrRn, 
 			  lookupLocatedInstDeclBndr,
 			  lookupLocatedSigOccRn, bindPatSigTyVars, bindPatSigTyVarsFV,
-			  bindLocalFixities,
+			  bindLocalFixities, bindSigTyVarsFV, 
 			  warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
 			)
 import CmdLineOpts	( DynFlag(..) )
@@ -298,7 +298,9 @@ mkBindVertex sigs (L loc (PatBind pat grhss ty))
 	names_bound_here = mkNameSet (collectPatBinders pat')
     in
     sigsForMe names_bound_here sigs	`thenM` \ sigs_for_me ->
-    rnGRHSs PatBindRhs grhss		`thenM` \ (grhss', fvs) ->
+    bindSigTyVarsFV sigs_for_me (
+        rnGRHSs PatBindRhs grhss
+    )					`thenM` \ (grhss', fvs) ->
     returnM 
 	(names_bound_here, fvs `plusFV` pat_fvs,
 	  L loc (PatBind pat' grhss' ty), sigs_for_me
@@ -312,7 +314,9 @@ mkBindVertex sigs (L loc (FunBind name inf matches))
 	names_bound_here = unitNameSet plain_name
     in
     sigsForMe names_bound_here sigs			`thenM` \ sigs_for_me ->
-    rnMatchGroup (FunRhs plain_name) matches		`thenM` \ (new_matches, fvs) ->
+    bindSigTyVarsFV sigs_for_me (
+    	rnMatchGroup (FunRhs plain_name) matches
+    )							`thenM` \ (new_matches, fvs) ->
     checkPrecMatch inf plain_name new_matches		`thenM_`
     returnM
       (unitNameSet plain_name, fvs,

ghc/compiler/rename/RnEnv.lhs

@@ -18,7 +18,7 @@ module RnEnv (
 	newLocalsRn, newIPNameRn,
 	bindLocalNames, bindLocalNamesFV,
 	bindLocatedLocalsFV, bindLocatedLocalsRn,
-	bindPatSigTyVars, bindPatSigTyVarsFV,
+	bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV,
 	bindTyVarsRn, extendTyVarEnvFVRn,
 	bindLocalFixities,
 
@@ -45,7 +45,7 @@ import RdrName		( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
 import HsTypes		( replaceTyVarName )
 import HscTypes		( availNames, ModIface(..), FixItem(..), lookupFixity )
 import TcRnMonad
-import Name		( Name, nameIsLocalOrFrom, mkInternalName, isInternalName,
+import Name		( Name, nameIsLocalOrFrom, mkInternalName, 
 			  nameSrcLoc, nameOccName, nameModule, nameParent, isExternalName )
 import NameSet
 import OccName		( tcName, isDataOcc, occNameFlavour, reportIfUnused )
@@ -557,15 +557,16 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
 		   (enclosed_scope names)
 
 
+bindLocalNames :: [Name] -> RnM a -> RnM a
 bindLocalNames names enclosed_scope
   = getLocalRdrEnv 		`thenM` \ name_env ->
     setLocalRdrEnv (extendLocalRdrEnv name_env names)
 		    enclosed_scope
 
+bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
 bindLocalNamesFV names enclosed_scope
-  = bindLocalNames names $
-    enclosed_scope `thenM` \ (thing, fvs) ->
-    returnM (thing, delListFromNameSet fvs names)
+  = do	{ (result, fvs) <- bindLocalNames names enclosed_scope
+	; returnM (result, delListFromNameSet fvs names) }
 
 
 -------------------------------------
@@ -579,15 +580,10 @@ bindLocatedLocalsFV doc rdr_names enclosed_scope
     returnM (thing, delListFromNameSet fvs names)
 
 -------------------------------------
-extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
-	-- This tiresome function is used only in rnSourceDecl on InstDecl
-extendTyVarEnvFVRn tyvars enclosed_scope
-  = bindLocalNames tyvars enclosed_scope 	`thenM` \ (thing, fvs) -> 
-    returnM (thing, delListFromNameSet fvs tyvars)
-
 bindTyVarsRn :: SDoc -> [LHsTyVarBndr RdrName]
 	      -> ([LHsTyVarBndr Name] -> RnM a)
 	      -> RnM a
+-- Haskell-98 binding of type variables; e.g. within a data type decl
 bindTyVarsRn doc_str tyvar_names enclosed_scope
   = let
 	located_tyvars = hsLTyVarLocNames tyvar_names
@@ -601,19 +597,22 @@ bindPatSigTyVars :: [LHsType RdrName] -> ([Name] -> RnM a) -> RnM a
   -- Find the type variables in the pattern type 
   -- signatures that must be brought into scope
 bindPatSigTyVars tys thing_inside
-  = getLocalRdrEnv		`thenM` \ name_env ->
-    let
-	located_tyvars  = nubBy eqLocated [ tv | ty <- tys,
-				    tv <- extractHsTyRdrTyVars ty,
-				    not (unLoc tv `elemLocalRdrEnv` name_env)
-			 ]
+  = do 	{ scoped_tyvars <- doptM Opt_ScopedTypeVariables
+	; if not scoped_tyvars then 
+		thing_inside []
+	  else 
+    do 	{ name_env <- getLocalRdrEnv
+	; let locd_tvs  = [ tv | ty <- tys
+			       , tv <- extractHsTyRdrTyVars ty
+			       , not (unLoc tv `elemLocalRdrEnv` name_env) ]
+	      nubbed_tvs = nubBy eqLocated locd_tvs
 		-- The 'nub' is important.  For example:
 		--	f (x :: t) (y :: t) = ....
 		-- We don't want to complain about binding t twice!
 
-	doc_sig        = text "In a pattern type-signature"
-    in
-    bindLocatedLocalsRn doc_sig located_tyvars thing_inside
+	; bindLocatedLocalsRn doc_sig nubbed_tvs thing_inside }}
+  where
+    doc_sig = text "In a pattern type-signature"
 
 bindPatSigTyVarsFV :: [LHsType RdrName]
 		   -> RnM (a, FreeVars)
@@ -623,6 +622,35 @@ bindPatSigTyVarsFV tys thing_inside
     thing_inside		`thenM` \ (result,fvs) ->
     returnM (result, fvs `delListFromNameSet` tvs)
 
+bindSigTyVarsFV :: [LSig Name]
+		-> RnM (a, FreeVars)
+	  	-> RnM (a, FreeVars)
+-- Bind the top-level forall'd type variables in the sigs.
+-- E.g 	f :: a -> a
+--	f = rhs
+--	The 'a' scopes over the rhs
+--
+-- NB: there'll usually be just one (for a function binding)
+--     but if there are many, one may shadow the rest; too bad!
+--	e.g  x :: [a] -> [a]
+--	     y :: [(a,a)] -> a
+--	     (x,y) = e
+--      In e, 'a' will be in scope, and it'll be the one from 'y'!
+bindSigTyVarsFV sigs thing_inside
+  = do	{ scoped_tyvars <- doptM Opt_ScopedTypeVariables
+	; if not scoped_tyvars then 
+		thing_inside 
+	  else
+		bindLocalNamesFV tvs thing_inside }
+  where
+    tvs = [ hsLTyVarName ltv 
+	  | L _ (Sig _ (L _ (HsForAllTy _ ltvs _ _))) <- sigs, ltv <- ltvs ]
+				
+
+extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
+	-- This function is used only in rnSourceDecl on InstDecl
+extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside
+
 -------------------------------------
 checkDupNames :: SDoc
 	      -> [Located RdrName]

ghc/compiler/typecheck/Inst.lhs

@@ -54,9 +54,9 @@ import TcMType	( zonkTcType, zonkTcTypes, zonkTcPredType,
 		  zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
 		)
 import TcType	( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar,
-		  PredType(..), typeKind,
+		  PredType(..), typeKind, mkSigmaTy,
 		  tcSplitForAllTys, tcSplitForAllTys, 
-		  tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy,
+		  tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy, tcSplitDFunHead,
 		  isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
 		  tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
 		  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
@@ -79,7 +79,7 @@ import Name	( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
 		  isInternalName, setNameUnique, mkSystemNameEncoded )
 import NameSet	( addOneToNameSet )
 import Literal	( inIntRange )
-import Var	( TyVar, tyVarKind )
+import Var	( TyVar, tyVarKind, setIdType )
 import VarEnv	( TidyEnv, emptyTidyEnv, lookupVarEnv )
 import VarSet	( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
 import TysWiredIn ( floatDataCon, doubleDataCon )
@@ -566,10 +566,15 @@ addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv
 -- Check that the proposed new instance is OK, 
 -- and then add it to the home inst env
 addInst dflags home_ie dfun
-  = do	{ 	-- Load imported instances, so that we report
+  = do	{ 	-- Instantiate the dfun type so that we extend the instance
+		-- envt with completely fresh template variables
+	  (tvs', theta', tau') <- tcInstType (idType dfun)
+	; let	(cls, tys') = tcSplitDFunHead tau'
+		dfun' 	    = setIdType dfun (mkSigmaTy tvs' theta' tau')	    
+
+		-- Load imported instances, so that we report
 		-- duplicates correctly
-	  let (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
-	; pkg_ie  <- loadImportedInsts cls tys
+	; pkg_ie  <- loadImportedInsts cls tys'
 
 		-- Check functional dependencies
 	; case checkFunDeps (pkg_ie, home_ie) dfun of
@@ -577,13 +582,9 @@ addInst dflags home_ie dfun
 		Nothing    -> return ()
 
 		-- Check for duplicate instance decls
-		-- We instantiate the dfun type because the instance lookup
-		-- requires nice fresh types in the thing to be looked up
-	; (tvs', _, tenv) <- tcInstTyVars tvs
-	; let { tys' = substTys tenv tys
-	      ; (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys'
+	; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys'
 	      ;	dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches,
-			  		isJust (tcMatchTys (mkVarSet tvs) tys' dup_tys)] }
+			  		isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
 		-- Find memebers of the match list which 
 		-- dfun itself matches. If the match is 2-way, it's a duplicate
 	; case dup_dfuns of
@@ -591,7 +592,7 @@ addInst dflags home_ie dfun
 	    []           -> return ()
 
 		-- OK, now extend the envt
-	; return (extendInstEnv home_ie dfun) }
+	; return (extendInstEnv home_ie dfun') }
 
 
 traceDFuns dfuns

ghc/compiler/typecheck/TcArrows.lhs

@@ -19,7 +19,7 @@ import TcMatches ( TcStmtCtxt(..), tcMatchPats, matchCtxt, tcStmts,
 import TcType	( TcType, TcTauType, TcRhoType, mkFunTys, mkTyConApp,
 		  mkTyVarTy, mkAppTys, tcSplitTyConApp_maybe, tcEqType, 
 		  SkolemInfo(..) )
-import TcMType	( newTyFlexiVarTy, newTyFlexiVarTys, tcSkolTyVar, zonkTcType )
+import TcMType	( newTyFlexiVarTy, newTyFlexiVarTys, tcSkolTyVars, zonkTcType )
 import TcBinds	( tcBindsAndThen )
 import TcSimplify ( tcSimplifyCheck )
 import TcUnify	( Expected(..), checkSigTyVarsWrt, zapExpectedTo )
@@ -244,7 +244,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
   = addErrCtxt (cmdCtxt cmd)	$
     do	{ cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..]
 	; span       <- getSrcSpanM
-	; w_tv       <- tcSkolTyVar (ArrowSkol span) alphaTyVar
+	; [w_tv]     <- tcSkolTyVars (ArrowSkol span) [alphaTyVar]
 	; let w_ty = mkTyVarTy w_tv 	-- Just a convenient starting point
 
 		--  a ((w,t1) .. tn) t

ghc/compiler/typecheck/TcBinds.lhs

@@ -21,16 +21,16 @@ import TcHsSyn		( TcId, TcDictBinds, zonkId, mkHsLet )
 
 import TcRnMonad
 import Inst		( InstOrigin(..), newDictsAtLoc, newIPDict, instToId )
-import TcEnv		( tcExtendIdEnv, tcExtendIdEnv2, newLocalName, tcLookupLocalIds )
+import TcEnv		( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv, newLocalName, tcLookupLocalIds )
 import TcUnify		( Expected(..), tcInfer, checkSigTyVars, sigCtxt )
 import TcSimplify	( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, 
 			  tcSimplifyToDicts, tcSimplifyIPs )
 import TcHsType		( tcHsSigType, UserTypeCtxt(..), tcAddLetBoundTyVars,
-			  TcSigInfo(..), TcSigFun, mkTcSig, lookupSig
+			  TcSigInfo(..), TcSigFun, lookupSig
 			)
 import TcPat		( tcPat, PatCtxt(..) )
 import TcSimplify	( bindInstsOfLocalFuns )
-import TcMType		( newTyFlexiVarTy, tcSkolType, zonkQuantifiedTyVar, zonkTcTypes )
+import TcMType		( newTyFlexiVarTy, tcSkolSigType, zonkQuantifiedTyVar, zonkTcTypes )
 import TcType		( TcTyVar, SkolemInfo(SigSkol), 
 			  TcTauType, TcSigmaType, 
 			  TvSubstEnv, mkTvSubst, substTheta, substTy, 
@@ -38,14 +38,13 @@ import TcType		( TcTyVar, SkolemInfo(SigSkol),
 			  mkForAllTy, isUnLiftedType, tcGetTyVar_maybe, 
 			  mkTyVarTys )
 import Unify		( tcMatchPreds )
-import Kind		( argTypeKind, isUnliftedTypeKind )
+import Kind		( argTypeKind )
 import VarEnv		( lookupVarEnv ) 
 import TysPrim		( alphaTyVar )
 import Id		( mkLocalId, mkSpecPragmaId, setInlinePragma )
 import Var		( idType, idName )
 import Name		( Name )
 import NameSet
-import Var		( tyVarKind )
 import VarSet
 import SrcLoc		( Located(..), unLoc, noLoc, getLoc )
 import Bag
@@ -435,22 +434,24 @@ tcMonoBinds :: LHsBinds Name
 	    -> TcSigFun -> RecFlag
 	    -> TcM (LHsBinds TcId, [MonoBindInfo])
 
-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
-
 tcMonoBinds binds lookup_sig is_rec
   = do	{ tc_binds <- mapBagM (wrapLocM (tcLhs lookup_sig)) binds
-	; let mono_info = getMonoBindInfo tc_binds
-	; binds' <- tcExtendIdEnv2 (rhsEnvExtension mono_info) $
+
+	-- Bring (a) the scoped type variables, and (b) the Ids, into scope for the RHSs
+	-- For (a) it's ok to bring them all into scope at once, even
+	-- though each type sig should scope only over its own RHS,
+	-- because the renamer has sorted all that out.
+	; let mono_info  = getMonoBindInfo tc_binds
+	      rhs_tvs    = [ tv | (_, Just sig, _) <- mono_info, tv <- sig_tvs sig ]
+	      rhs_id_env = map mk mono_info 	-- A binding for each term variable
+
+	; binds' <- tcExtendTyVarEnv rhs_tvs    $
+		    tcExtendIdEnv2   rhs_id_env $
 		    mapBagM (wrapLocM tcRhs) tc_binds
 	; return (binds', mono_info) }
+   where
+    mk (name, Just sig, _)       = (name, sig_id sig)	-- Use the type sig if there is one
+    mk (name, Nothing,  mono_id) = (name, mono_id)	-- otherwise use a monomorphic version
 
 ------------------------
 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
@@ -472,6 +473,16 @@ 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 lookup_sig (FunBind (L nm_loc name) inf matches)
   = do	{ let mb_sig = lookup_sig name
@@ -505,7 +516,7 @@ tcLhs lookup_sig bind@(PatBind pat grhss _)
 
 -------------------
 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
-tcRhs (TcFunBind _ fun'@(L _ mono_id) inf matches)
+tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches)
   = do	{ matches' <- tcMatchesFun (idName mono_id) matches 
 				   (Check (idType mono_id))
 	; return (FunBind fun' inf matches') }
@@ -523,15 +534,6 @@ getMonoBindInfo tc_binds
   where
     get_info (TcFunBind info _ _ _)  rest = info : rest
     get_info (TcPatBind infos _ _ _) rest = infos ++ rest
-
----------------------
-rhsEnvExtension :: [MonoBindInfo] -> [(Name, TcId)]
--- Environment for RHS of definitions: use type sig if there is one
-rhsEnvExtension mono_info
-  = map mk mono_info
-  where
-    mk (name, Just sig, _)       = (name, sig_id sig)
-    mk (name, Nothing,  mono_id) = (name, mono_id)
 \end{code}
 
 
@@ -548,42 +550,47 @@ tcTySigs :: [LSig Name] -> TcM [TcSigInfo]
 -- all the right hand sides agree a common vocabulary for their type
 -- constraints
 tcTySigs [] = return []
-tcTySigs (L span (Sig (L _ name) ty) : sigs)
-  = do  { 	-- Typecheck the first signature
-	; sigma1 <- setSrcSpan span $
-		    tcHsSigType (FunSigCtxt name) ty
-	; let id1 = mkLocalId name sigma1
-	; tc_sig1 <- mkTcSig id1
 
-	; tc_sigs <- mapM (tcTySig tc_sig1) sigs
-	; return (tc_sig1 : tc_sigs) }
+tcTySigs sigs
+  = do	{ (tc_sig1 : tc_sigs) <- mappM tcTySig sigs
+	; tc_sigs' 	      <- mapM (checkSigCtxt tc_sig1) tc_sigs
+        ; return (tc_sig1 : tc_sigs') }
 
-tcTySig sig1 (L span (Sig (L _ name) ty))
+tcTySig :: LSig Name -> TcM TcSigInfo
+tcTySig (L span (Sig (L _ name) ty))
   = setSrcSpan span		$
     do	{ sigma_ty <- tcHsSigType (FunSigCtxt name) ty
-	; (tvs, theta, tau) <- tcSkolType rigid_info sigma_ty
-	; let poly_id  = mkLocalId name sigma_ty
-	      bale_out = failWithTc $
-		         sigContextsErr (sig_id sig1) name sigma_ty 
+	; let rigid_info = SigSkol name
+	      poly_id    = mkLocalId name sigma_ty
+	; (tvs, theta, tau) <- tcSkolSigType rigid_info sigma_ty
+	; loc <- getInstLoc (SigOrigin rigid_info)
+	; return (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, 
+			      sig_theta = theta, sig_tau = tau, 
+			      sig_loc = loc }) }
 
-	-- Try to match the context of this signature with 
+checkSigCtxt :: TcSigInfo -> TcSigInfo -> TcM TcSigInfo
+checkSigCtxt sig1 sig@(TcSigInfo { sig_tvs = tvs, sig_theta = theta, sig_tau = tau })
+  = 	-- Try to match the context of this signature with 
 	-- that of the first signature
-	; case tcMatchPreds tvs theta (sig_theta sig1) of { 
-	    Nothing   -> bale_out
-	;   Just tenv -> do
-	; case check_tvs tenv tvs of
-	    Nothing   -> bale_out
-	    Just tvs' -> do {
-
-	  let subst  = mkTvSubst tenv
-	      theta' = substTheta subst theta
-	      tau'   = substTy subst tau
-	; loc <- getInstLoc (SigOrigin rigid_info)
-	; return (TcSigInfo { sig_id = poly_id, sig_tvs = tvs', 
-			      sig_theta = theta', sig_tau = tau', 
-			      sig_loc = loc }) }}}
+    case tcMatchPreds (sig_tvs sig) (sig_theta sig) (sig_theta sig1) of {
+	Nothing   -> bale_out ;
+	Just tenv ->
+
+    case check_tvs tenv tvs of {
+	Nothing   -> bale_out ;
+	Just tvs' -> 
+
+    let 
+	subst  = mkTvSubst tenv
+    in
+    return (sig { sig_tvs   = tvs', 
+		  sig_theta = substTheta subst theta, 
+		  sig_tau   = substTy subst tau }) }}
+
   where
-    rigid_info = SigSkol name
+    bale_out =	setSrcSpan (instLocSrcSpan (sig_loc sig)) $
+	 	failWithTc $
+		sigContextsErr (sig_id sig1) (sig_id sig)
 
 	-- Rather tedious check that the type variables
 	-- have been matched only with another type variable,
@@ -832,10 +839,10 @@ valSpecSigCtxt v ty
 	 nest 4 (ppr v <+> dcolon <+> ppr ty)]
 
 -----------------------------------------------
-sigContextsErr id1 name ty
+sigContextsErr id1 id2
   = vcat [ptext SLIT("Mis-match between the contexts of the signatures for"), 
 	  nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1),
-			ppr name <+> dcolon <+> ppr ty]),
+			ppr id2 <+> dcolon <+> ppr (idType id2)]),
 	  ptext SLIT("The signature contexts in a mutually recursive group should all be identical")]
 
 

ghc/compiler/typecheck/TcClassDcl.lhs

@@ -20,7 +20,7 @@ import RnEnv		( lookupTopBndrRn, lookupImportedName )
 
 import Inst		( Inst, InstOrigin(..), instToId, newDicts, newDictsAtLoc, newMethod )
 import TcEnv		( tcLookupLocatedClass, tcExtendIdEnv2, 
-			  tcExtendTyVarEnv2,
+			  tcExtendTyVarEnv, 
 			  InstInfo(..), pprInstInfoDetails,
 			  simpleInstInfoTyCon, simpleInstInfoTy,
 			  InstBindings(..), newDFunName
@@ -29,7 +29,7 @@ import TcBinds		( tcMonoBinds, tcSpecSigs )
 import TcHsType		( TcSigInfo(..), mkTcSig, tcHsKindedType, tcHsSigType )
 import TcSimplify	( tcSimplifyCheck, bindInstsOfLocalFuns )
 import TcUnify		( checkSigTyVars, sigCtxt )
-import TcMType		( tcSkolTyVars, UserTypeCtxt( GenPatCtxt ) )
+import TcMType		( tcSkolSigTyVars, UserTypeCtxt( GenPatCtxt ) )
 import TcType		( Type, SkolemInfo(ClsSkol, InstSkol), 
 			  TcType, TcThetaType, TcTyVar, mkTyVarTys,
 			  mkClassPred, tcSplitSigmaTy, tcSplitFunTys,
@@ -51,7 +51,6 @@ import NameSet		( emptyNameSet, unitNameSet, nameSetToList )
 import OccName		( reportIfUnused, mkDefaultMethodOcc )
 import RdrName		( RdrName, mkDerivedRdrName )
 import Outputable
-import Var		( TyVar )
 import PrelNames	( genericTyConNames )
 import CmdLineOpts
 import UnicodeUtil	( stringToUtf8 )
@@ -263,19 +262,17 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
     
 tcDefMeth clas tyvars binds_in prags sel_id
   = do	{ dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id)
-	; let rigid_info = ClsSkol clas
-	; clas_tyvars <- tcSkolTyVars rigid_info tyvars
-	; let
+	; let	rigid_info  = ClsSkol clas
+		clas_tyvars = tcSkolSigTyVars rigid_info tyvars
 		inst_tys    = mkTyVarTys clas_tyvars
 		dm_ty       = idType sel_id	-- Same as dict selector!
 	        theta       = [mkClassPred clas inst_tys]
 		local_dm_id = mkDefaultMethodId dm_name dm_ty
-		xtve 	    = tyvars `zip` clas_tyvars
 		origin 	    = SigOrigin rigid_info
 
 	; (_, meth_info) <- mkMethodBind origin clas inst_tys binds_in (sel_id, DefMeth)
 	; [this_dict] <- newDicts origin theta
-	; (defm_bind, insts_needed) <- getLIE (tcMethodBind xtve clas_tyvars theta 
+	; (defm_bind, insts_needed) <- getLIE (tcMethodBind clas_tyvars theta 
 							    [this_dict] prags meth_info)
     
 	; addErrCtxt (defltMethCtxt clas) $ do
@@ -322,11 +319,11 @@ type MethodSpec = (Id, 			-- Global selector Id
 		   LHsBind Name)	-- Binding for the method
 
 tcMethodBind 
-	:: [(TyVar,TcTyVar)]	-- Bindings for type environment
-	-> [TcTyVar]		-- Instantiated type variables for the
+	:: [TcTyVar]		-- Skolemised type variables for the
 				--  	enclosing class/instance decl. 
 				--  	They'll be signature tyvars, and we
 				--  	want to check that they don't get bound
+				-- Also they are scoped, so we bring them into scope
 				-- Always equal the range of the type envt
 	-> TcThetaType		-- Available theta; it's just used for the error message
 	-> [Inst]		-- Available from context, used to simplify constraints 
@@ -335,7 +332,7 @@ tcMethodBind
 	-> MethodSpec		-- Details of this method
 	-> TcM (LHsBinds Id)
 
-tcMethodBind xtve inst_tyvars inst_theta avail_insts prags
+tcMethodBind inst_tyvars inst_theta avail_insts prags
 	     (sel_id, meth_id, meth_bind)
   = recoverM (returnM emptyLHsBinds) $
 	-- If anything fails, recover returning no bindings.
@@ -349,7 +346,7 @@ tcMethodBind xtve inst_tyvars inst_theta avail_insts prags
      let lookup_sig name = ASSERT( name == idName meth_id ) 
 			   Just meth_sig
      in
-     tcExtendTyVarEnv2 xtve (
+     tcExtendTyVarEnv inst_tyvars (
 	addErrCtxt (methodCtxt sel_id)			$
 	getLIE 						$
 	tcMonoBinds (unitBag meth_bind) lookup_sig NonRecursive

ghc/compiler/typecheck/TcDeriv.lhs

@@ -20,7 +20,7 @@ import TcEnv		( newDFunName, pprInstInfoDetails,
 			  tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv
 			)
 import TcGenDeriv	-- Deriv stuff
-import InstEnv		( simpleDFunClassTyCon, extendInstEnv )
+import InstEnv		( simpleDFunClassTyCon, extendInstEnvList )
 import TcHsType		( tcHsDeriv )
 import TcSimplify	( tcSimplifyDeriv )
 
@@ -723,7 +723,7 @@ extendLocalInstEnv :: [DFunId] -> TcM a -> TcM a
 -- for functional dependency errors -- that'll happen in TcInstDcls
 extendLocalInstEnv dfuns thing_inside
  = do { env <- getGblEnv
-      ; let  inst_env' = foldl extendInstEnv (tcg_inst_env env) dfuns 
+      ; let  inst_env' = extendInstEnvList (tcg_inst_env env) dfuns 
 	     env'      = env { tcg_inst_env = inst_env' }
       ; setGblEnv env' thing_inside }
 \end{code}

ghc/compiler/typecheck/TcEnv.lhs

@@ -17,7 +17,7 @@ module TcEnv(
 	
 	-- Local environment
 	tcExtendKindEnv,
-	tcExtendTyVarEnv, tcExtendTyVarEnv2, tcExtendTyVarEnv3, 
+	tcExtendTyVarEnv, tcExtendTyVarEnv3, 
 	tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, 
 	tcLookup, tcLookupLocated, tcLookupLocalIds,
 	tcLookupId, tcLookupTyVar,
@@ -250,10 +250,6 @@ tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
 tcExtendTyVarEnv tvs thing_inside
   = tc_extend_tv_env [ATyVar tv (mkTyVarTy tv) | tv <- tvs] thing_inside
 
-tcExtendTyVarEnv2 :: [(TyVar,TcTyVar)] -> TcM r -> TcM r
-tcExtendTyVarEnv2 tv_pairs thing_inside
-  = tc_extend_tv_env [ATyVar tv1 (mkTyVarTy tv2) | (tv1,tv2) <- tv_pairs] thing_inside
-
 tcExtendTyVarEnv3 :: [(TyVar,TcType)] -> TcM r -> TcM r
 tcExtendTyVarEnv3 ty_pairs thing_inside
   = tc_extend_tv_env [ATyVar tv1 ty2 | (tv1,ty2) <- ty_pairs] thing_inside
@@ -559,8 +555,8 @@ as well as explicit user written ones.
 \begin{code}
 data InstInfo
   = InstInfo {
-      iDFunId :: DFunId,		-- The dfun id
-      iBinds  :: InstBindings
+      iDFunId :: DFunId,		-- The dfun id.  Its forall'd type variables 
+      iBinds  :: InstBindings		-- scope over the stuff in InstBindings!
     }
 
 data InstBindings

ghc/compiler/typecheck/TcHsType.lhs

@@ -41,8 +41,7 @@ import TcUnify		( unifyFunKind, checkExpectedKind )
 import TcType		( Type, PredType(..), ThetaType, 
 			  SkolemInfo(SigSkol), MetaDetails(Flexi),
 			  TcType, TcTyVar, TcKind, TcThetaType, TcTauType,
-			  mkTyVarTy, mkFunTy, 
-		 	  mkForAllTys, mkFunTys, tcEqType, isPredTy,
+		 	  mkForAllTys, mkFunTys, tcEqType, isPredTy, mkFunTy, 
 			  mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys, 
 			  tcSplitFunTy_maybe, tcSplitForAllTys )
 import Kind 		( Kind, isLiftedTypeKind, liftedTypeKind, ubxTupleKind, 

ghc/compiler/typecheck/TcInstDcls.lhs

@@ -13,14 +13,14 @@ import TcBinds		( tcSpecSigs )
 import TcClassDcl	( tcMethodBind, mkMethodBind, badMethodErr, 
 			  tcClassDecl2, getGenericInstances )
 import TcRnMonad       
-import TcMType		( tcSkolType, checkValidTheta, checkValidInstHead, instTypeErr, 
+import TcMType		( tcSkolSigType, checkValidTheta, checkValidInstHead, instTypeErr, 
 			  checkAmbiguity, SourceTyCtxt(..) )
-import TcType		( mkClassPred, tcSplitForAllTys, tyVarsOfType, 
-			  tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, mkTyVarTys,
+import TcType		( mkClassPred, tyVarsOfType, 
+			  tcSplitSigmaTy, getClassPredTys, tcSplitDFunHead, mkTyVarTys,
 			  SkolemInfo(InstSkol), tcSplitDFunTy, pprClassPred )
 import Inst		( tcInstClassOp, newDicts, instToId, showLIE, tcExtendLocalInstEnv )
 import TcDeriv		( tcDeriving )