X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsUtils.lhs;h=f8efa6cfb94f206e7047953e32c87d6b486eacac;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=8019f362828142d3fae23023da861850831cfdd0;hpb=a7ecdf96844404b7bc8273d4ff6d85759278427c;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsUtils.lhs b/ghc/compiler/hsSyn/HsUtils.lhs
index 8019f36..f8efa6c 100644
--- a/ghc/compiler/hsSyn/HsUtils.lhs
+++ b/ghc/compiler/hsSyn/HsUtils.lhs
@@ -27,7 +27,7 @@ import RdrName		( RdrName, getRdrName, mkRdrUnqual )
 import Var		( Id )
 import Type		( Type )
 import DataCon		( DataCon, dataConWrapId, dataConSourceArity )
-import OccName		( mkVarOcc )
+import OccName		( mkVarOccFS )
 import Name		( Name )
 import BasicTypes	( RecFlag(..) )
 import SrcLoc
@@ -100,7 +100,7 @@ mkHsDictLet binds expr
   | isEmptyLHsBinds binds = expr
   | otherwise             = L (getLoc expr) (HsLet (HsValBinds val_binds) expr)
 			  where
-			    val_binds = ValBindsOut [(Recursive, binds)]
+			    val_binds = ValBindsOut [(Recursive, binds)] []
 
 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
 -- Used for constructing dictinoary terms etc, so no locations 
@@ -136,11 +136,15 @@ mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2
 
 mkHsSplice e = HsSplice unqualSplice e
 
-unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice"))
+unqualSplice = mkRdrUnqual (mkVarOccFS FSLIT("splice"))
 		-- A name (uniquified later) to
 		-- identify the splice
 
 mkHsString s = HsString (mkFastString s)
+
+-------------
+userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)]
+userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ]
 \end{code}
 
 
@@ -221,18 +225,17 @@ nlHsFunTy a b		= noLoc (HsFunTy a b)
 %************************************************************************
 
 \begin{code}
-mkVarBind :: SrcSpan -> name -> LHsExpr name -> LHsBind name
-mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyLHsBinds rhs
+mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
+mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
 
 ------------
-mk_easy_FunBind :: SrcSpan -> name -> [LPat name]
-		-> LHsBinds name -> LHsExpr name
-		-> LHsBind name
+mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
+		-> LHsExpr RdrName -> LHsBind RdrName
 
-mk_easy_FunBind loc fun pats binds expr
+mk_easy_FunBind loc fun pats expr
   = L loc (FunBind (L loc fun) False{-not infix-} matches placeHolderNames)
   where
-    matches = mkMatchGroup [mk_easy_Match pats binds expr]
+    matches = mkMatchGroup [mkMatch pats expr emptyLocalBinds]
 
 ------------
 mk_FunBind :: SrcSpan -> RdrName
@@ -246,10 +249,6 @@ mk_FunBind loc fun pats_and_exprs
     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 -> HsLocalBinds id -> LMatch id
 mkMatch pats expr binds
   = noLoc (Match (map paren pats) Nothing 
@@ -284,8 +283,10 @@ collectLocalBinders (HsIPBinds _)   = []
 collectLocalBinders EmptyLocalBinds = []
 
 collectHsValBinders :: HsValBinds name -> [Located name]
-collectHsValBinders (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds
-collectHsValBinders (ValBindsOut binds)     = panic "collectHsValBinders"
+collectHsValBinders (ValBindsIn binds sigs)  = collectHsBindLocatedBinders binds
+collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds
+  where
+   collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds
 
 collectAcc :: HsBind name -> [Located name] -> [Located name]
 collectAcc (PatBind pat _ _ _) acc = collectLocatedPatBinders pat ++ acc
@@ -315,8 +316,8 @@ collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 Get all the pattern type signatures out of a bunch of bindings
 
 \begin{code}
-collectSigTysFromHsBinds :: [LHsBind name] -> [LHsType name]
-collectSigTysFromHsBinds binds = concat (map collectSigTysFromHsBind binds)
+collectSigTysFromHsBinds :: LHsBinds name -> [LHsType name]
+collectSigTysFromHsBinds binds = concatMap collectSigTysFromHsBind (bagToList binds)
 
 collectSigTysFromHsBind :: LHsBind name -> [LHsType name]
 collectSigTysFromHsBind bind