[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, 46 insertions, 43 deletions

diff --git a/ghc/compiler/hsSyn/HsUtils.lhs b/ghc/compiler/hsSyn/HsUtils.lhs
index d2e757e373..8019f36282 100644
--- a/ghc/compiler/hsSyn/HsUtils.lhs
+++ b/ghc/compiler/hsSyn/HsUtils.lhs
@@ -27,9 +27,9 @@ import RdrName		( RdrName, getRdrName, mkRdrUnqual )
 import Var		( Id )
 import Type		( Type )
 import DataCon		( DataCon, dataConWrapId, dataConSourceArity )
-import BasicTypes	( RecFlag(..) )
 import OccName		( mkVarOcc )
 import Name		( Name )
+import BasicTypes	( RecFlag(..) )
 import SrcLoc
 import FastString	( mkFastString )
 import Outputable
@@ -56,7 +56,7 @@ mkHsPar e = L (getLoc e) (HsPar e)
 mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
 mkSimpleMatch pats rhs 
   = L loc $
-    Match pats Nothing (GRHSs (unguardedRHS rhs) [])
+    Match pats Nothing (GRHSs (unguardedRHS rhs) emptyLocalBinds)
   where
     loc = case pats of
 		[]      -> getLoc rhs
@@ -93,10 +93,14 @@ mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr)
 mkHsDictLam []    expr = expr
 mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr)
 
-mkHsLet :: LHsBinds name -> LHsExpr name -> LHsExpr name
-mkHsLet binds expr 
+mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id
+-- Used for the dictionary bindings gotten from TcSimplify
+-- We make them recursive to be on the safe side
+mkHsDictLet binds expr 
   | isEmptyLHsBinds binds = expr
-  | otherwise             = L (getLoc expr) (HsLet [HsBindGroup binds [] Recursive] expr)
+  | otherwise             = L (getLoc expr) (HsLet (HsValBinds val_binds) expr)
+			  where
+			    val_binds = ValBindsOut [(Recursive, binds)]
 
 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
 -- Used for constructing dictinoary terms etc, so no locations 
@@ -110,10 +114,6 @@ mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
 mkSimpleHsAlt pat expr 
   = mkSimpleMatch [pat] expr
 
-glueBindsOnGRHSs :: HsBindGroup id -> GRHSs id -> GRHSs id
-glueBindsOnGRHSs binds1 (GRHSs grhss binds2)
-  = GRHSs grhss (binds1 : binds2)
-
 -------------------------------
 -- These are the bits of syntax that contain rebindable names
 -- See RnEnv.lookupSyntaxName
@@ -224,34 +224,35 @@ nlHsFunTy a b		= noLoc (HsFunTy a b)
 mkVarBind :: SrcSpan -> name -> LHsExpr name -> LHsBind name
 mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyLHsBinds rhs
 
+------------
 mk_easy_FunBind :: SrcSpan -> name -> [LPat name]
-		    -> LHsBinds name -> LHsExpr name
-		    -> LHsBind name
+		-> LHsBinds name -> LHsExpr name
+		-> LHsBind name
 
 mk_easy_FunBind loc fun pats binds expr
-  = L loc (FunBind (L loc fun) False{-not infix-} 
-	  	   (mkMatchGroup [mk_easy_Match pats binds expr]))
-
-mk_easy_Match pats binds expr
-  = mkMatch pats expr [HsBindGroup binds [] Recursive]
-	-- The renamer expects everything in its input to be a
-	-- "recursive" MonoBinds, and it is its job to sort things out
-	-- from there.
+  = L loc (FunBind (L loc fun) False{-not infix-} matches placeHolderNames)
+  where
+    matches = mkMatchGroup [mk_easy_Match pats binds expr]
 
-mk_FunBind	:: SrcSpan 
-		-> RdrName
-		-> [([LPat RdrName], LHsExpr RdrName)]
-		-> LHsBind RdrName
+------------
+mk_FunBind :: SrcSpan -> RdrName
+	   -> [([LPat RdrName], LHsExpr RdrName)]
+	   -> LHsBind RdrName
 
 mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
 mk_FunBind loc fun pats_and_exprs
-  = L loc (FunBind (L loc fun) False{-not infix-} 
-		   (mkMatchGroup [mkMatch p e [] | (p,e) <-pats_and_exprs]))
+  = L loc (FunBind (L loc fun) False{-not infix-} matches placeHolderNames)
+  where
+    matches = mkMatchGroup [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
+
+------------
+mk_easy_Match pats binds expr
+  = mkMatch pats expr (HsValBinds (ValBindsIn binds []))
 
-mkMatch :: [LPat id] -> LHsExpr id -> [HsBindGroup id] -> LMatch id
+------------
+mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
 mkMatch pats expr binds
   = noLoc (Match (map paren pats) Nothing 
--- gaw 2004
 		 (GRHSs (unguardedRHS expr) binds))
   where
     paren p = case p of
@@ -277,29 +278,30 @@ where
 it should return [x, y, f, a, b] (remember, order important).
 
 \begin{code}
-collectGroupBinders :: [HsBindGroup name] -> [Located name]
-collectGroupBinders groups = foldr collect_group [] groups
-	where
-	  collect_group (HsBindGroup bag sigs is_rec) acc
-	 	= foldrBag (collectAcc . unLoc) acc bag
-	  collect_group (HsIPBinds _) acc = acc
+collectLocalBinders :: HsLocalBinds name -> [Located name]
+collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
+collectLocalBinders (HsIPBinds _)   = []
+collectLocalBinders EmptyLocalBinds = []
 
+collectHsValBinders :: HsValBinds name -> [Located name]
+collectHsValBinders (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds
+collectHsValBinders (ValBindsOut binds)     = panic "collectHsValBinders"
 
 collectAcc :: HsBind name -> [Located name] -> [Located name]
-collectAcc (PatBind pat _ _) acc = collectLocatedPatBinders pat ++ acc
-collectAcc (FunBind f _ _) acc   = f : acc
-collectAcc (VarBind f _) acc  = noLoc f : acc
-collectAcc (AbsBinds _ _ dbinds _ binds) acc
-  = [noLoc dp | (_,dp,_) <- dbinds] ++ acc
+collectAcc (PatBind pat _ _ _) acc = collectLocatedPatBinders pat ++ acc
+collectAcc (FunBind f _ _ _) acc   = f : acc
+collectAcc (VarBind f _) acc       = noLoc f : acc
+collectAcc (AbsBinds _ _ dbinds binds) acc
+  = [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc
 	-- ++ foldr collectAcc acc binds
 	-- I don't think we want the binders from the nested binds
 	-- The only time we collect binders from a typechecked 
 	-- binding (hence see AbsBinds) is in zonking in TcHsSyn
 
-collectHsBindBinders :: Bag (LHsBind name) -> [name]
+collectHsBindBinders :: LHsBinds name -> [name]
 collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
 
-collectHsBindLocatedBinders :: Bag (LHsBind name) -> [Located name]
+collectHsBindLocatedBinders :: LHsBinds name -> [Located name]
 collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 \end{code}
 
@@ -320,13 +322,14 @@ collectSigTysFromHsBind :: LHsBind name -> [LHsType name]
 collectSigTysFromHsBind bind
   = go (unLoc bind)
   where
-    go (PatBind pat _ _) 
+    go (PatBind pat _ _ _) 
 	= collectSigTysFromPat pat
-    go (FunBind f _ (MatchGroup ms _))
+    go (FunBind f _ (MatchGroup ms _) _)
 	= [sig | L _ (Match [] (Just sig) _) <- ms]
 	-- A binding like    x :: a = f y
 	-- is parsed as FunMonoBind, but for this purpose we 	
 	-- want to treat it as a pattern binding
+    go out_bind = panic "collectSigTysFromHsBind"
 \end{code}
 
 %************************************************************************
@@ -348,7 +351,7 @@ collectLStmtBinders = collectStmtBinders . unLoc
 collectStmtBinders :: Stmt id -> [Located id]
   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
-collectStmtBinders (LetStmt binds)      = collectGroupBinders binds
+collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
 collectStmtBinders (ExprStmt _ _ _)   	= []
 collectStmtBinders (RecStmt ss _ _ _ _)	= collectLStmtsBinders ss
 collectStmtBinders other              	= panic "collectStmtBinders"