[project @ 2005-07-19 16:44:50 by simonpj]

WARNING: this is a big commit.  You might want 
	to wait a few days before updating, in case I've 
	broken something.

	However, if any of the changes are what you wanted,
	please check it out and test!

This commit does three main things:

1. A re-organisation of the way that GHC handles bindings in HsSyn.
   This has been a bit of a mess for quite a while.  The key new
   types are

	-- Bindings for a let or where clause
	data HsLocalBinds id
	  = HsValBinds (HsValBinds id)
	  | HsIPBinds  (HsIPBinds id)
	  | EmptyLocalBinds

	-- Value bindings (not implicit parameters)
	data HsValBinds id
	  = ValBindsIn  -- Before typechecking
		(LHsBinds id) [LSig id]	-- Not dependency analysed
					-- Recursive by default

	  | ValBindsOut	-- After typechecking
		[(RecFlag, LHsBinds id)]-- Dependency analysed

2. Implement Mark Jones's idea of increasing polymoprhism
   by using type signatures to cut the strongly-connected components
   of a recursive group.  As a consequence, GHC no longer insists
   on the contexts of the type signatures of a recursive group
   being identical.

   This drove a significant change: the renamer no longer does dependency
   analysis.  Instead, it attaches a free-variable set to each binding,
   so that the type checker can do the dep anal.  Reason: the typechecker
   needs to do *two* analyses:
	one to find the true mutually-recursive groups
		(which we need so we can build the right CoreSyn)
	one to find the groups in which to typecheck, taking
		account of type signatures

3. Implement non-ground SPECIALISE pragmas, as promised, and as
   requested by Remi and Ross.  Certainly, this should fix the 
   current problem with GHC, namely that if you have
	g :: Eq a => a -> b -> b
   then you can now specialise thus
	SPECIALISE g :: Int -> b -> b
    (This didn't use to work.)

   However, it goes further than that.  For example:
	f :: (Eq a, Ix b) => a -> b -> b
   then you can make a partial specialisation
	SPECIALISE f :: (Eq a) => a -> Int -> Int

    In principle, you can specialise f to *any* type that is
    "less polymorphic" (in the sense of subsumption) than f's 
    actual type.  Such as
	SPECIALISE f :: Eq a => [a] -> Int -> Int
    But I haven't tested that.

    I implemented this by doing the specialisation in the typechecker
    and desugarer, rather than leaving around the strange SpecPragmaIds,
    for the specialiser to find.  Indeed, SpecPragmaIds have vanished 
    altogether (hooray).

    Pragmas in general are handled more tidily.  There's a new
    data type HsBinds.Prag, which lives in an AbsBinds, and carries
    pragma info from the typechecker to the desugarer.


Smaller things

- The loop in the renamer goes via RnExpr, instead of RnSource.
  (That makes it more like the type checker.)

- I fixed the thing that was causing 'check_tc' warnings to be 
  emitted.

1 files changed, 18 insertions, 16 deletions

diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index fe5b95b94a..bd1a5c6057 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -15,7 +15,7 @@ import Check            ( check, ExhaustivePat )
 import CoreSyn
 import CoreUtils	( bindNonRec, exprType )
 import DsMonad
-import DsBinds		( dsHsNestedBinds )
+import DsBinds		( dsLHsBinds )
 import DsGRHSs		( dsGRHSs )
 import DsUtils
 import Id		( idName, idType, Id )
@@ -90,19 +90,21 @@ The next two functions create the warning message.
 
 \begin{code}
 dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
-dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn 
-	where
-	  warn | qs `lengthExceeds` maximum_output
-               = pp_context ctx (ptext SLIT("are overlapped"))
-		            (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
-			    ptext SLIT("..."))
-	       | otherwise
-               = pp_context ctx (ptext SLIT("are overlapped"))
-	                    (\ f -> vcat $ map (ppr_eqn f kind) qs)
+dsShadowWarn ctx@(DsMatchContext kind _ loc) qs
+  = putSrcSpanDs loc (dsWarn warn)
+  where
+    warn | qs `lengthExceeds` maximum_output
+         = pp_context ctx (ptext SLIT("are overlapped"))
+		      (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
+		      ptext SLIT("..."))
+	 | otherwise
+         = pp_context ctx (ptext SLIT("are overlapped"))
+	              (\ f -> vcat $ map (ppr_eqn f kind) qs)
 
 
 dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
-dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn 
+dsIncompleteWarn ctx@(DsMatchContext kind _ loc) pats 
+  = putSrcSpanDs loc (dsWarn warn)
 	where
 	  warn = pp_context ctx (ptext SLIT("are non-exhaustive"))
                     	    (\f -> hang (ptext SLIT("Patterns not matched:"))
@@ -113,9 +115,9 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn
 	  dots | pats `lengthExceeds` maximum_output = ptext SLIT("...")
 	       | otherwise                           = empty
 
-pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun
-  = (loc, vcat [ptext SLIT("Pattern match(es)") <+> msg,
-	        sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]])
+pp_context (DsMatchContext kind pats _loc) msg rest_of_msg_fun
+  = vcat [ptext SLIT("Pattern match(es)") <+> msg,
+	  sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]
   where
     (ppr_match, pref)
 	= case kind of
@@ -341,7 +343,7 @@ Float, 	Double, at least) are converted to unboxed form; e.g.,
 
 \begin{code}
 tidyEqnInfo :: Id -> EquationInfo -> DsM EquationInfo
-	-- DsM'd because of internal call to dsHsNestedBinds
+	-- DsM'd because of internal call to dsLHsBinds
 	-- 	and mkSelectorBinds.
 	-- "tidy1" does the interesting stuff, looking at
 	-- one pattern and fiddling the list of bindings.
@@ -399,7 +401,7 @@ tidy1 v wrap (VarPat var)
   = returnDs (wrap . wrapBind var v, WildPat (idType var)) 
 
 tidy1 v wrap (VarPatOut var binds)
-  = do	{ prs <- dsHsNestedBinds binds
+  = do	{ prs <- dsLHsBinds binds
 	; return (wrap . wrapBind var v . mkDsLet (Rec prs),
 		  WildPat (idType var)) }