X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsUtils.lhs;h=be4431d234157630397feae55c1a9ddb95abe36a;hp=cbc59c4ba44a3f874f883821653b97ec78e9bb07;hb=ab22f4e6456820c1b5169d75f5975a94e61f54ce;hpb=108361d05dfb0aa37871c2c6a4ddec45a1b68010

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index cbc59c4..be4431d 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The University of Glasgow, 1992-2003
+% (c) The University of Glasgow, 1992-2006
 %
 
 Here we collect a variety of helper functions that construct or
@@ -22,18 +22,19 @@ import HsExpr
 import HsPat
 import HsTypes	
 import HsLit
-
-import RdrName		( RdrName, getRdrName, mkRdrUnqual )
-import Var		( Id )
-import Type		( Type )
-import DataCon		( DataCon, dataConWrapId, dataConSourceArity )
-import OccName		( mkVarOccFS )
-import Name		( Name )
-import BasicTypes	( RecFlag(..) )
+import HsDecls
+
+import RdrName
+import Var
+import Type
+import DataCon
+import OccName
+import Name
+import BasicTypes
 import SrcLoc
-import FastString	( mkFastString )
+import FastString
 import Outputable
-import Util		( nOfThem )
+import Util
 import Bag
 \end{code}
 
@@ -72,14 +73,14 @@ mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
 mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
 
 nlHsTyApp :: name -> [Type] -> LHsExpr name
-nlHsTyApp fun_id tys = noLoc (HsCoerce (CoTyApps tys) (HsVar fun_id))
+nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id))
 
-mkLHsCoerce :: ExprCoFn -> LHsExpr id -> LHsExpr id
-mkLHsCoerce co_fn (L loc e) = L loc (mkHsCoerce co_fn e)
+mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
+mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
 
-mkHsCoerce :: ExprCoFn -> HsExpr id -> HsExpr id
-mkHsCoerce co_fn e | isIdCoercion co_fn = e
-		   | otherwise		= HsCoerce co_fn e
+mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
+mkHsWrap co_fn e | isIdHsWrapper co_fn = e
+		 | otherwise	      = HsWrap co_fn e
 
 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
@@ -224,7 +225,7 @@ nlHsFunTy a b		= noLoc (HsFunTy a b)
 mkFunBind :: Located id -> [LMatch id] -> HsBind id
 -- Not infix, with place holders for coercion and free vars
 mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms,
-			    fun_co_fn = idCoercion, bind_fvs = placeHolderNames }
+			    fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames }
 
 
 mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
@@ -416,3 +417,24 @@ collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats
 collect_pat (ConPatIn c ps)     acc = foldr collect_lpat acc (hsConArgs ps)
 collect_pat other	        acc = acc 	-- Literals, vars, wildcard
 \end{code}
+
+%************************************************************************
+%*									*
+%* 	Getting the main binder name of a top declaration
+%*									*
+%************************************************************************
+
+\begin{code}
+
+getMainDeclBinder :: HsDecl name -> Maybe name
+getMainDeclBinder (TyClD d) = Just (tcdName d)
+getMainDeclBinder (ValD d)
+   = case collectAcc d [] of
+        []       -> Nothing   -- see rn003
+        (name:_) -> Just (unLoc name)
+getMainDeclBinder (SigD d) = sigNameNoLoc d
+getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name)
+getMainDeclBinder (ForD (ForeignExport name _ _)) = Just (unLoc name)
+getMainDeclBinder _ = Nothing
+
+\end{code}