X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FhsSyn%2FHsUtils.lhs;h=c1d1a10b2eaf1fa59c8b8a2de920e80826e73931;hb=74b27e20425336403d80e942ee3faf00f8c36ef8;hp=da0e24c6c107de650f6fdb75e29a8c4f8af5526d;hpb=e6d057711f4d6d6ff6342c39fa2b9e44d25447f1;p=ghc-hetmet.git

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index da0e24c..c1d1a10 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
@@ -23,17 +23,16 @@ 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 RdrName
+import Var
+import Type
+import DataCon
+import Name
+import BasicTypes
 import SrcLoc
-import FastString	( mkFastString )
+import FastString
 import Outputable
-import Util		( nOfThem )
+import Util
 import Bag
 \end{code}
 
@@ -52,16 +51,18 @@ just attach noSrcSpan to everything.
 mkHsPar :: LHsExpr id -> LHsExpr id
 mkHsPar e = L (getLoc e) (HsPar e)
 
--- gaw 2004
 mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id
 mkSimpleMatch pats rhs 
   = L loc $
-    Match pats Nothing (GRHSs (unguardedRHS rhs) emptyLocalBinds)
+    Match pats Nothing (unguardedGRHSs rhs)
   where
     loc = case pats of
 		[]      -> getLoc rhs
 		(pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
 
+unguardedGRHSs :: LHsExpr id -> GRHSs id
+unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds
+
 unguardedRHS :: LHsExpr id -> [LGRHS id]
 unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
 
@@ -116,6 +117,7 @@ mkSimpleHsAlt pat expr
 
 mkHsIntegral   i       = HsIntegral   i  noSyntaxExpr
 mkHsFractional f       = HsFractional f  noSyntaxExpr
+mkHsIsString   s       = HsIsString   s  noSyntaxExpr
 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
 
 mkNPat lit neg     = NPat lit neg noSyntaxExpr placeHolderType
@@ -210,6 +212,8 @@ nlList exprs		= noLoc (ExplicitList placeHolderType exprs)
 nlHsAppTy f t		= noLoc (HsAppTy f t)
 nlHsTyVar x		= noLoc (HsTyVar x)
 nlHsFunTy a b		= noLoc (HsFunTy a b)
+
+nlHsTyConApp tycon tys  = foldl nlHsAppTy (nlHsTyVar tycon) tys
 \end{code}
 
 
@@ -224,7 +228,8 @@ 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 = idHsWrapper, bind_fvs = placeHolderNames }
+			    fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames,
+			    fun_tick = Nothing }
 
 
 mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
@@ -314,22 +319,24 @@ collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
 %************************************************************************
 
 \begin{code}
-collectLStmtsBinders :: [LStmt id] -> [Located id]
+collectLStmtsBinders :: OutputableBndr id => [LStmt id] -> [Located id]
 collectLStmtsBinders = concatMap collectLStmtBinders
 
-collectStmtsBinders :: [Stmt id] -> [Located id]
+collectStmtsBinders :: OutputableBndr id => [Stmt id] -> [Located id]
 collectStmtsBinders = concatMap collectStmtBinders
 
-collectLStmtBinders :: LStmt id -> [Located id]
+collectLStmtBinders :: OutputableBndr id => LStmt id -> [Located id]
 collectLStmtBinders = collectStmtBinders . unLoc
 
-collectStmtBinders :: Stmt id -> [Located id]
+collectStmtBinders :: OutputableBndr id => Stmt id -> [Located id]
   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
 collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat
 collectStmtBinders (LetStmt binds)      = collectLocalBinders binds
-collectStmtBinders (ExprStmt _ _ _)   	= []
-collectStmtBinders (RecStmt ss _ _ _ _)	= collectLStmtsBinders ss
-collectStmtBinders other              	= panic "collectStmtBinders"
+collectStmtBinders (ExprStmt _ _ _)     = []
+collectStmtBinders (ParStmt xs)         = collectLStmtsBinders
+                                        $ concatMap fst xs
+collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
+collectStmtBinders s                    = pprPanic "collectStmtBinders" (ppr s)
 \end{code}
 
 
@@ -377,23 +384,28 @@ collectl (L l pat) bndrs
     go (TuplePat pats _ _)  	  = foldr collectl bndrs pats
 				  
     go (ConPatIn c ps)   	  = foldr collectl bndrs (hsConArgs ps)
-    go (ConPatOut { pat_dicts = ds, 
-		    pat_binds = bs, pat_args = ps })
-				  = map noLoc ds
-				    ++ collectHsBindLocatedBinders bs
-				    ++ foldr collectl bndrs (hsConArgs ps)
+    go (ConPatOut {pat_args=ps})  = foldr collectl bndrs (hsConArgs ps)
+	-- See Note [Dictionary binders in ConPatOut]
     go (LitPat _)	      	  = bndrs
     go (NPat _ _ _ _)		  = bndrs
     go (NPlusKPat n _ _ _)        = n : bndrs
-
+ 				  
     go (SigPatIn pat _)	 	  = collectl pat bndrs
     go (SigPatOut pat _)	  = collectl pat bndrs
     go (TypePat ty)               = bndrs
-    go (DictPat ids1 ids2)        = map noLoc ids1 ++ map noLoc ids2
-				    ++ bndrs
     go (CoPat _ pat ty)           = collectl (noLoc pat) bndrs
 \end{code}
 
+Note [Dictionary binders in ConPatOut]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Do *not* gather (a) dictionary and (b) dictionary bindings as binders
+of a ConPatOut pattern.  For most calls it doesn't matter, because
+it's pre-typechecker and there are no ConPatOuts.  But it does matter
+more in the desugarer; for example, DsUtils.mkSelectorBinds uses
+collectPatBinders.  In a lazy pattern, for example f ~(C x y) = ...,
+we want to generate bindings for x,y but not for dictionaries bound by
+C.  (The type checker ensures they would not be used.)
+
 \begin{code}
 collectSigTysFromPats :: [InPat name] -> [LHsType name]
 collectSigTysFromPats pats = foldr collect_lpat [] pats