1 files changed, 125 insertions, 131 deletions

diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs
index c5ba50eba0..ed835ca5eb 100644
--- a/ghc/compiler/rename/RnBinds.lhs
+++ b/ghc/compiler/rename/RnBinds.lhs
@@ -10,7 +10,7 @@ they may be affected by renaming (which isn't fully worked out yet).
 
 \begin{code}
 module RnBinds (
-	rnTopMonoBinds, rnMonoBinds, rnMonoBindsAndThen,
+	rnTopBinds, rnBinds, rnBindsAndThen,
 	rnMethodBinds, renameSigs, checkSigs
    ) where
 
@@ -18,14 +18,15 @@ module RnBinds (
 
 
 import HsSyn
-import HsBinds		( hsSigDoc, sigLoc, eqHsSig )
+import HsBinds		( hsSigDoc, eqHsSig )
 import RdrHsSyn
 import RnHsSyn
 import TcRnMonad
-import RnTypes		( rnHsSigType, rnHsType, rnPat )
+import RnTypes		( rnHsSigType, rnLHsType, rnLPat )
 import RnExpr		( rnMatch, rnGRHSs, checkPrecMatch )
-import RnEnv		( bindLocatedLocalsRn, lookupBndrRn, lookupInstDeclBndr,
-			  lookupSigOccRn, bindPatSigTyVars, bindPatSigTyVarsFV,
+import RnEnv		( bindLocatedLocalsRn, lookupLocatedBndrRn, 
+			  lookupLocatedInstDeclBndr,
+			  lookupLocatedSigOccRn, bindPatSigTyVars, bindPatSigTyVarsFV,
 			  bindLocalFixities,
 			  warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
 			)
@@ -37,7 +38,11 @@ import PrelNames	( isUnboundName )
 import RdrName		( RdrName, rdrNameOcc )
 import BasicTypes	( RecFlag(..), TopLevelFlag(..), isTopLevel )
 import List		( unzip4 )
+import SrcLoc		( mkSrcSpan, Located(..), unLoc )
+import Bag
 import Outputable
+
+import Monad		( foldM )
 \end{code}
 
 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
@@ -96,7 +101,7 @@ a set of variables free in @Exp@ is written @fvExp@
 
 %************************************************************************
 %*									*
-%* analysing polymorphic bindings (HsBinds, Bind, MonoBinds)		*
+%* analysing polymorphic bindings (HsBindGroup, HsBind)
 %*									*
 %************************************************************************
 
@@ -150,20 +155,20 @@ it expects the global environment to contain bindings for the binders
 contains bindings for the binders of this particular binding.
 
 \begin{code}
-rnTopMonoBinds :: RdrNameMonoBinds 
-	       -> [RdrNameSig]
-	       -> RnM (RenamedHsBinds, DefUses)
+rnTopBinds :: Bag (LHsBind RdrName)
+	   -> [LSig RdrName]
+	   -> RnM ([HsBindGroup Name], DefUses)
 
 -- The binders of the binding are in scope already;
 -- the top level scope resolution does that
 
-rnTopMonoBinds mbinds sigs
- =  bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $ \ _ -> 
+rnTopBinds mbinds sigs
+ =  bindPatSigTyVars (collectSigTysFromHsBinds (bagToList mbinds)) $ \ _ -> 
 	-- Hmm; by analogy with Ids, this doesn't look right
 	-- Top-level bound type vars should really scope over 
 	-- everything, but we only scope them over the other bindings
 
-    rnMonoBinds TopLevel mbinds sigs
+    rnBinds TopLevel mbinds sigs
 \end{code}
 
 
@@ -174,24 +179,24 @@ rnTopMonoBinds mbinds sigs
 %************************************************************************
 
 \begin{code}
-rnMonoBindsAndThen :: RdrNameMonoBinds 
-	           -> [RdrNameSig]
-	   	   -> (RenamedHsBinds -> RnM (result, FreeVars))
-		   -> RnM (result, FreeVars)
+rnBindsAndThen :: Bag (LHsBind RdrName)
+	       -> [LSig RdrName]
+	       -> ([HsBindGroup Name] -> RnM (result, FreeVars))
+	       -> RnM (result, FreeVars)
 
-rnMonoBindsAndThen mbinds sigs thing_inside -- Non-empty monobinds
+rnBindsAndThen mbinds sigs thing_inside
   =	-- Extract all the binders in this group, and extend the
 	-- current scope, inventing new names for the new binders
 	-- This also checks that the names form a set
     bindLocatedLocalsRn doc mbinders_w_srclocs			$ \ _ ->
-    bindPatSigTyVarsFV (collectSigTysFromMonoBinds mbinds)	$ 
+    bindPatSigTyVarsFV (collectSigTysFromHsBinds (bagToList mbinds))	$ 
 
 	-- Then install local fixity declarations
 	-- Notice that they scope over thing_inside too
-    bindLocalFixities [sig | FixSig sig <- sigs ] 	$
+    bindLocalFixities [sig | L _ (FixSig sig) <- sigs ] 	$
 
 	-- Do the business
-    rnMonoBinds NotTopLevel mbinds sigs	`thenM` \ (binds, bind_dus) ->
+    rnBinds NotTopLevel mbinds sigs	`thenM` \ (binds, bind_dus) ->
 
 	-- Now do the "thing inside"
     thing_inside binds 			`thenM` \ (result,result_fvs) ->
@@ -213,15 +218,15 @@ rnMonoBindsAndThen mbinds sigs thing_inside -- Non-empty monobinds
 	-- bindings in the wrong order, and the type checker will complain
 	-- that x isn't in scope
   where
-    mbinders_w_srclocs = collectLocatedMonoBinders mbinds
+    mbinders_w_srclocs = collectHsBindLocatedBinders mbinds
     doc = text "In the binding group for:"
-	  <+> pprWithCommas ppr (map fst mbinders_w_srclocs)
+	  <+> pprWithCommas ppr (map unLoc mbinders_w_srclocs)
 \end{code}
 
 
 %************************************************************************
 %*									*
-\subsubsection{		MonoBinds -- the main work is done here}
+\subsubsection{rnBinds -- the main work is done here}
 %*									*
 %************************************************************************
 
@@ -231,27 +236,26 @@ This is done {\em either} by pass 3 (for the top-level bindings),
 {\em or} by @rnMonoBinds@ (for the nested ones).
 
 \begin{code}
-rnMonoBinds :: TopLevelFlag
-	    -> RdrNameMonoBinds 
-	    -> [RdrNameSig]
-	    -> RnM (RenamedHsBinds, DefUses)
+rnBinds :: TopLevelFlag
+	-> Bag (LHsBind RdrName)
+	-> [LSig RdrName]
+	-> RnM ([HsBindGroup Name], DefUses)
 
 -- Assumes the binders of the binding are in scope already
 
-rnMonoBinds top_lvl mbinds sigs
+rnBinds top_lvl mbinds sigs
  =  renameSigs sigs			`thenM` \ siglist ->
 
-  	 -- Rename the bindings, returning a MonoBindsInfo
+  	 -- Rename the bindings, returning a [HsBindVertex]
 	 -- which is a list of indivisible vertices so far as
 	 -- the strongly-connected-components (SCC) analysis is concerned
-    flattenMonoBinds siglist mbinds	`thenM` \ mbinds_info ->
+    mkBindVertices siglist mbinds	`thenM` \ mbinds_info ->
 
 	 -- Do the SCC analysis
     let 
 	scc_result  = rnSCC mbinds_info
-	(binds_s, bind_dus_s) = unzip (map reconstructCycle scc_result)
+	(groups, bind_dus_s) = unzip (map reconstructCycle scc_result)
 	bind_dus    = mkDUs bind_dus_s	
-	final_binds = foldr ThenBinds EmptyBinds binds_s
 	binders     = duDefs bind_dus
     in
 	-- Check for duplicate or mis-placed signatures
@@ -264,7 +268,7 @@ rnMonoBinds top_lvl mbinds sigs
     (if isTopLevel top_lvl && 
 	 warn_missing_sigs
      then let
-	    type_sig_vars   = [n | Sig n _ _ <- siglist]
+	    type_sig_vars   = [ unLoc n | L _ (Sig n _) <- siglist]
 	    un_sigd_binders = filter (not . (`elem` type_sig_vars)) 
 				     (nameSetToList binders)
 	  in
@@ -273,27 +277,22 @@ rnMonoBinds top_lvl mbinds sigs
 	returnM ()  
     )						`thenM_`
 
-    returnM (final_binds, bind_dus `plusDU` usesOnly (hsSigsFVs siglist))
+    returnM (groups, bind_dus `plusDU` usesOnly (hsSigsFVs siglist))
 \end{code}
 
-@flattenMonoBinds@ is ever-so-slightly magical in that it sticks
+@mkBindVertices@ is ever-so-slightly magical in that it sticks
 unique ``vertex tags'' on its output; minor plumbing required.
 
 \begin{code}
-flattenMonoBinds :: [RenamedSig]		-- Signatures
-		 -> RdrNameMonoBinds
-		 -> RnM [FlatMonoBinds]
-
-flattenMonoBinds sigs EmptyMonoBinds = returnM []
+mkBindVertices :: [LSig Name]		-- Signatures
+	       -> Bag (LHsBind RdrName)
+	       -> RnM [BindVertex]
+mkBindVertices sigs = mapM (mkBindVertex sigs) . bagToList
 
-flattenMonoBinds sigs (AndMonoBinds bs1 bs2)
-  = flattenMonoBinds sigs bs1	`thenM` \ flat1 ->
-    flattenMonoBinds sigs bs2	`thenM` \ flat2 ->
-    returnM (flat1 ++ flat2)
-
-flattenMonoBinds sigs (PatMonoBind pat grhss locn)
-  = addSrcLoc locn		 	$
-    rnPat pat				`thenM` \ (pat', pat_fvs) ->
+mkBindVertex :: [LSig Name] -> LHsBind RdrName -> RnM BindVertex
+mkBindVertex sigs (L loc (PatBind pat grhss))
+  = addSrcSpan loc $
+    rnLPat pat				`thenM` \ (pat', pat_fvs) ->
 
 	 -- Find which things are bound in this group
     let
@@ -302,30 +301,33 @@ flattenMonoBinds sigs (PatMonoBind pat grhss locn)
     sigsForMe names_bound_here sigs	`thenM` \ sigs_for_me ->
     rnGRHSs PatBindRhs grhss		`thenM` \ (grhss', fvs) ->
     returnM 
-	[(names_bound_here, fvs `plusFV` pat_fvs,
-	  PatMonoBind pat' grhss' locn, sigs_for_me
-	)]
+	(names_bound_here, fvs `plusFV` pat_fvs,
+	  L loc (PatBind pat' grhss'), sigs_for_me
+	)
 
-flattenMonoBinds sigs (FunMonoBind name inf matches locn)
-  = addSrcLoc locn				 	$
-    lookupBndrRn name					`thenM` \ new_name ->
+mkBindVertex sigs (L loc (FunBind name inf matches))
+  = addSrcSpan loc $ 
+    lookupLocatedBndrRn name				`thenM` \ new_name ->
     let
-	names_bound_here = unitNameSet new_name
+	plain_name = unLoc new_name
+	names_bound_here = unitNameSet plain_name
     in
     sigsForMe names_bound_here sigs			`thenM` \ sigs_for_me ->
-    mapFvRn (rnMatch (FunRhs new_name)) matches		`thenM` \ (new_matches, fvs) ->
-    mappM_ (checkPrecMatch inf new_name) new_matches	`thenM_`
+    mapFvRn (rnMatch (FunRhs plain_name)) matches	`thenM` \ (new_matches, fvs) ->
+    mappM_ (checkPrecMatch inf plain_name) new_matches	`thenM_`
     returnM
-      [(unitNameSet new_name, fvs,
-	FunMonoBind new_name inf new_matches locn, sigs_for_me
-      )]
+      (unitNameSet plain_name, fvs,
+	L loc (FunBind new_name inf new_matches), sigs_for_me
+      )
 
 sigsForMe names_bound_here sigs
   = foldlM check [] (filter (sigForThisGroup names_bound_here) sigs)
   where
 	-- sigForThisGroup only returns signatures for 
 	-- which sigName returns a Just
-    check sigs sig = case filter (eqHsSig sig) sigs of
+    eq sig1 sig2 = eqHsSig (unLoc sig1) (unLoc sig2)
+
+    check sigs sig = case filter (eq sig) sigs of
 			[]    -> returnM (sig:sigs)
 			other -> dupSigDeclErr sig other	`thenM_`
 				 returnM sigs
@@ -333,7 +335,7 @@ sigsForMe names_bound_here sigs
 
 
 @rnMethodBinds@ is used for the method bindings of a class and an instance
-declaration.   Like @rnMonoBinds@ but without dependency analysis.
+declaration.   Like @rnBinds@ but without dependency analysis.
 
 NOTA BENE: we record each {\em binder} of a method-bind group as a free variable.
 That's crucial when dealing with an instance decl:
@@ -350,67 +352,61 @@ a binder.
 \begin{code}
 rnMethodBinds :: Name			-- Class name
 	      -> [Name]			-- Names for generic type variables
-	      -> RdrNameMonoBinds
-	      -> RnM (RenamedMonoBinds, FreeVars)
+	      -> (LHsBinds RdrName)
+	      -> RnM (LHsBinds Name, FreeVars)
 
-rnMethodBinds cls gen_tyvars EmptyMonoBinds = returnM (EmptyMonoBinds, emptyFVs)
+rnMethodBinds cls gen_tyvars binds
+  = foldM do_one (emptyBag,emptyFVs) (bagToList binds)
+  where do_one (binds,fvs) bind = do
+	   (bind', fvs_bind) <- rnMethodBind cls gen_tyvars bind
+	   return (bind' `unionBags` binds, fvs_bind `plusFV` fvs)
 
-rnMethodBinds cls gen_tyvars (AndMonoBinds mb1 mb2)
-  = rnMethodBinds cls gen_tyvars mb1	`thenM` \ (mb1', fvs1) ->
-    rnMethodBinds cls gen_tyvars mb2	`thenM` \ (mb2', fvs2) ->
-    returnM (mb1' `AndMonoBinds` mb2', fvs1 `plusFV` fvs2)
 
-rnMethodBinds cls gen_tyvars (FunMonoBind name inf matches locn)
-  = addSrcLoc locn				   	$
-
-    lookupInstDeclBndr cls name				`thenM` \ sel_name -> 
+rnMethodBind cls gen_tyvars (L loc (FunBind name inf matches))
+  =  addSrcSpan loc $ 
+     lookupLocatedInstDeclBndr cls name			`thenM` \ sel_name -> 
+     let plain_name = unLoc sel_name in
 	-- We use the selector name as the binder
 
-    mapFvRn (rn_match sel_name) matches			`thenM` \ (new_matches, fvs) ->
-    mappM_ (checkPrecMatch inf sel_name) new_matches	`thenM_`
-    returnM (FunMonoBind sel_name inf new_matches locn, fvs `addOneFV` sel_name)
+    mapFvRn (rn_match plain_name) matches		`thenM` \ (new_matches, fvs) ->
+    mappM_ (checkPrecMatch inf plain_name) new_matches	`thenM_`
+    returnM (unitBag (L loc (FunBind sel_name inf new_matches)), fvs `addOneFV` plain_name)
   where
 	-- Gruesome; bring into scope the correct members of the generic type variables
 	-- See comments in RnSource.rnSourceDecl(ClassDecl)
-    rn_match sel_name match@(Match (TypePat ty : _) _ _)
+    rn_match sel_name match@(L _ (Match (L _ (TypePat ty) : _) _ _))
 	= extendTyVarEnvFVRn gen_tvs 	$
 	  rnMatch (FunRhs sel_name) match
 	where
-	  tvs     = map rdrNameOcc (extractHsTyRdrTyVars ty)
+	  tvs     = map (rdrNameOcc.unLoc) (extractHsTyRdrTyVars ty)
 	  gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs] 
 
     rn_match sel_name match = rnMatch (FunRhs sel_name) match
-	
+
 
 -- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBinds cls gen_tyvars mbind@(PatMonoBind other_pat _ locn)
-  = addSrcLoc locn (addErr (methodBindErr mbind))	`thenM_`
-    returnM (EmptyMonoBinds, emptyFVs) 
+rnMethodBind cls gen_tyvars mbind@(L loc (PatBind other_pat _))
+  = addLocErr mbind methodBindErr	`thenM_`
+    returnM (emptyBag, emptyFVs) 
 \end{code}
 
 
 %************************************************************************
 %*									*
 	Strongly connected components
-
 %*									*
 %************************************************************************
 
-During analysis a @MonoBinds@ is flattened to a @FlatMonoBinds@.
-The @RenamedMonoBinds@ is always an empty bind, a pattern binding or
-a function binding, and has itself been dependency-analysed and
-renamed.
-
 \begin{code}
-type FlatMonoBinds = (Defs, Uses, RenamedMonoBinds, [RenamedSig])
+type BindVertex = (Defs, Uses, LHsBind Name, [LSig Name])
 			-- Signatures, if any, for this vertex
 
-rnSCC :: [FlatMonoBinds] -> [SCC FlatMonoBinds]
+rnSCC :: [BindVertex] -> [SCC BindVertex]
 rnSCC nodes = stronglyConnComp (mkEdges nodes)
 
 type VertexTag	= Int
 
-mkEdges :: [FlatMonoBinds] -> [(FlatMonoBinds, VertexTag, [VertexTag])]
+mkEdges :: [BindVertex] -> [(BindVertex, VertexTag, [VertexTag])]
 	-- We keep the uses with the binding, 
 	-- so we can track unused bindings better
 mkEdges nodes
@@ -426,16 +422,16 @@ mkEdges nodes
 			   defs `intersectsNameSet` uses
 			 ]
 
-reconstructCycle :: SCC FlatMonoBinds -> (RenamedHsBinds, (Defs,Uses))
-reconstructCycle (AcyclicSCC (defs, uses, binds, sigs))
-  = (MonoBind binds sigs NonRecursive, (defs, uses))
+reconstructCycle :: SCC BindVertex -> (HsBindGroup Name, (Defs,Uses))
+reconstructCycle (AcyclicSCC (defs, uses, bind, sigs))
+  = (HsBindGroup (unitBag bind) sigs NonRecursive, (defs, uses))
 reconstructCycle (CyclicSCC cycle)
-  = (MonoBind this_gp_binds this_gp_sigs Recursive, 
+  = (HsBindGroup this_gp_binds this_gp_sigs Recursive, 
      (unionManyNameSets defs_s, unionManyNameSets uses_s))
   where
     (defs_s, uses_s, binds_s, sigs_s) = unzip4 cycle
-    this_gp_binds = foldr1 AndMonoBinds binds_s
-    this_gp_sigs  = foldr1 (++)	        sigs_s
+    this_gp_binds = listToBag binds_s
+    this_gp_sigs  = foldr1 (++) sigs_s
 \end{code}
 
 
@@ -456,8 +452,8 @@ At the moment we don't gather free-var info from the types in
 signatures.  We'd only need this if we wanted to report unused tyvars.
 
 \begin{code}
-checkSigs :: (RenamedSig -> Bool)	-- OK-sig predicbate
-	  -> [RenamedSig]
+checkSigs :: (LSig Name -> Bool)	-- OK-sig predicbate
+	  -> [LSig Name]
 	  -> RnM ()
 checkSigs ok_sig sigs
 	-- Check for (a) duplicate signatures
@@ -467,7 +463,8 @@ checkSigs ok_sig sigs
   where
     bad sig = not (ok_sig sig) && 
 	      case sigName sig of
-		Just n | isUnboundName n -> False	-- Don't complain about an unbound name again
+		Just n | isUnboundName n -> False
+				-- Don't complain about an unbound name again
 		other			 -> True
 
 -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
@@ -479,33 +476,29 @@ checkSigs ok_sig sigs
 -- is in scope.  (I'm assuming that Baz.op isn't in scope unqualified.)
 -- Doesn't seem worth much trouble to sort this.
 
-renameSigs :: [Sig RdrName] -> RnM [Sig Name]
-renameSigs sigs = mappM renameSig (filter (not . isFixitySig) sigs)
+renameSigs :: [LSig RdrName] -> RnM [LSig Name]
+renameSigs sigs = mappM (wrapLocM renameSig) (filter (not . isFixitySig . unLoc) sigs)
 	-- Remove fixity sigs which have been dealt with already
 
 renameSig :: Sig RdrName -> RnM (Sig Name)
 -- FixitSig is renamed elsewhere.
-renameSig (Sig v ty src_loc)
-  = addSrcLoc src_loc $
-    lookupSigOccRn v				`thenM` \ new_v ->
+renameSig (Sig v ty)
+  = lookupLocatedSigOccRn v			`thenM` \ new_v ->
     rnHsSigType (quotes (ppr v)) ty		`thenM` \ new_ty ->
-    returnM (Sig new_v new_ty src_loc)
+    returnM (Sig new_v new_ty)
 
-renameSig (SpecInstSig ty src_loc)
-  = addSrcLoc src_loc $
-    rnHsType (text "A SPECIALISE instance pragma") ty `thenM` \ new_ty ->
-    returnM (SpecInstSig new_ty src_loc)
+renameSig (SpecInstSig ty)
+  = rnLHsType (text "A SPECIALISE instance pragma") ty `thenM` \ new_ty ->
+    returnM (SpecInstSig new_ty)
 
-renameSig (SpecSig v ty src_loc)
-  = addSrcLoc src_loc $
-    lookupSigOccRn v			`thenM` \ new_v ->
+renameSig (SpecSig v ty)
+  = lookupLocatedSigOccRn v		`thenM` \ new_v ->
     rnHsSigType (quotes (ppr v)) ty	`thenM` \ new_ty ->
-    returnM (SpecSig new_v new_ty src_loc)
+    returnM (SpecSig new_v new_ty)
 
-renameSig (InlineSig b v p src_loc)
-  = addSrcLoc src_loc $
-    lookupSigOccRn v		`thenM` \ new_v ->
-    returnM (InlineSig b new_v p src_loc)
+renameSig (InlineSig b v p)
+  = lookupLocatedSigOccRn v		`thenM` \ new_v ->
+    returnM (InlineSig b new_v p)
 \end{code}
 
 
@@ -516,24 +509,25 @@ renameSig (InlineSig b v p src_loc)
 %************************************************************************
 
 \begin{code}
-dupSigDeclErr sig sigs
-  = addSrcLoc loc $
-    addErr (vcat [ptext SLIT("Duplicate") <+> what_it_is <> colon,
-		  nest 2 (vcat (map ppr_sig (sig:sigs)))])
+dupSigDeclErr (L loc sig) sigs
+  = addErrAt loc $
+	vcat [ptext SLIT("Duplicate") <+> what_it_is <> colon,
+	      nest 2 (vcat (map ppr_sig (L loc sig:sigs)))]
   where
-    (what_it_is, loc) = hsSigDoc sig
-    ppr_sig sig = ppr (sigLoc sig) <> colon <+> ppr sig
+    what_it_is = hsSigDoc sig
+    ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig
 
-unknownSigErr sig
-  = addSrcLoc loc $
-    addErr (sep [ptext SLIT("Misplaced") <+> what_it_is <> colon,
-		   ppr sig])
+unknownSigErr (L loc sig)
+  = addErrAt loc $
+	sep [ptext SLIT("Misplaced") <+> what_it_is <> colon, ppr sig]
   where
-    (what_it_is, loc) = hsSigDoc sig
+    what_it_is = hsSigDoc sig
 
 missingSigWarn var
-  = addSrcLoc (nameSrcLoc var) $
-    addWarn (sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)])
+  = addWarnAt (mkSrcSpan loc loc) $
+      sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)]
+  where 
+    loc = nameSrcLoc var  -- TODO: make a proper span
 
 methodBindErr mbind
  =  hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding"))