X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsBinds.lhs;h=7437f09f2979c9043f77369144a05dc8b763710b;hb=3a223cd2811d46295048b3a2dab11403ca291b20;hp=bb2c8b2bb78f1ee25a4ad9d32f344e03039e1ed3;hpb=b085ee40c7f265a5977ea6ec1c415e573be5ff8c;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index bb2c8b2..7437f09 100644
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -15,16 +15,16 @@ import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr,
 			       GRHSs,  pprPatBind )
 
 -- friends:
-import HsImpExp		( ppr_var )
+import HsImpExp		( pprHsVar )
+import HsPat		( Pat )
 import HsTypes		( HsType )
-import CoreSyn		( CoreExpr )
 import PprCore		( {- instance Outputable (Expr a) -} )
 
 --others:
 import Name		( Name )
 import PrelNames	( isUnboundName )
 import NameSet		( NameSet, elemNameSet, nameSetToList )
-import BasicTypes	( RecFlag(..), Fixity, Activation(..) )
+import BasicTypes	( RecFlag(..), FixitySig(..), Activation(..), IPName )
 import Outputable	
 import SrcLoc		( SrcLoc )
 import Var		( TyVar )
@@ -46,37 +46,48 @@ grammar.
 Collections of bindings, created by dependency analysis and translation:
 
 \begin{code}
-data HsBinds id pat		-- binders and bindees
+data HsBinds id		-- binders and bindees
   = EmptyBinds
-
-  | ThenBinds	(HsBinds id pat)
-		(HsBinds id pat)
-
-  | MonoBind 	(MonoBinds id pat)
-		[Sig id]		-- Empty on typechecker output
-		RecFlag
+  | ThenBinds	(HsBinds id) (HsBinds id)
+
+  | MonoBind 			-- A mutually recursive group
+	(MonoBinds id)
+	[Sig id]		-- Empty on typechecker output, Type Signatures
+	RecFlag
+
+  | IPBinds			-- Implcit parameters
+				-- Not allowed at top level
+	[(IPName id, HsExpr id)]
+	Bool		-- True <=> this was a 'with' binding
+			--  (tmp, until 'with' is removed)
 \end{code}
 
 \begin{code}
-nullBinds :: HsBinds id pat -> Bool
+nullBinds :: HsBinds id -> Bool
 
 nullBinds EmptyBinds		= True
 nullBinds (ThenBinds b1 b2)	= nullBinds b1 && nullBinds b2
 nullBinds (MonoBind b _ _)	= nullMonoBinds b
+nullBinds (IPBinds b _)   	= null b
 
-mkMonoBind :: MonoBinds id pat -> [Sig id] -> RecFlag -> HsBinds id pat
-mkMonoBind EmptyMonoBinds _ _ = EmptyBinds
-mkMonoBind mbinds sigs is_rec = MonoBind mbinds sigs is_rec
+mkMonoBind :: RecFlag -> MonoBinds id -> HsBinds id
+mkMonoBind _      EmptyMonoBinds  = EmptyBinds
+mkMonoBind is_rec mbinds 	  = MonoBind mbinds [] is_rec
 \end{code}
 
 \begin{code}
-instance (Outputable pat, Outputable id) =>
-		Outputable (HsBinds id pat) where
+instance (OutputableBndr id) => Outputable (HsBinds id) where
     ppr binds = ppr_binds binds
 
 ppr_binds EmptyBinds = empty
 ppr_binds (ThenBinds binds1 binds2)
     = ppr_binds binds1 $$ ppr_binds binds2
+
+ppr_binds (IPBinds binds is_with)
+  = sep (punctuate semi (map pp_item binds))
+  where
+    pp_item (id,rhs) = pprBndr LetBind id <+> equals <+> pprExpr rhs
+
 ppr_binds (MonoBind bind sigs is_rec)
      = vcat [ppr_isrec,
      	     vcat (map ppr sigs),
@@ -99,11 +110,11 @@ ppr_binds (MonoBind bind sigs is_rec)
 Global bindings (where clauses)
 
 \begin{code}
-data MonoBinds id pat
+data MonoBinds id
   = EmptyMonoBinds
 
-  | AndMonoBinds    (MonoBinds id pat)
-		    (MonoBinds id pat)
+  | AndMonoBinds    (MonoBinds id)
+		    (MonoBinds id)
 
   | FunMonoBind     id		-- Used for both functions 	f x = e
 				-- and variables		f = \x -> e
@@ -114,26 +125,23 @@ data MonoBinds id pat
 				-- FunMonoBinds, so if you change this, you'll need to
 				-- change e.g. rnMethodBinds
 		    Bool		-- True => infix declaration
-		    [Match id pat]
+		    [Match id]
 		    SrcLoc
 
-  | PatMonoBind     pat		-- The pattern is never a simple variable;
+  | PatMonoBind     (Pat id)	-- The pattern is never a simple variable;
 				-- That case is done by FunMonoBind
-		    (GRHSs id pat)
+		    (GRHSs id)
 		    SrcLoc
 
   | VarMonoBind	    id			-- TRANSLATION
-		    (HsExpr id pat)
-
-  | CoreMonoBind    id			-- TRANSLATION
-		    CoreExpr		-- No zonking; this is a final CoreExpr with Ids and Types!
+		    (HsExpr id)
 
   | AbsBinds				-- Binds abstraction; TRANSLATION
 		[TyVar]	  		-- Type variables
 		[id]			-- Dicts
 		[([TyVar], id, id)]	-- (type variables, polymorphic, momonmorphic) triples
 		NameSet			-- Set of *polymorphic* variables that have an INLINE pragma
-		(MonoBinds id pat)      -- The "business end"
+		(MonoBinds id)      -- The "business end"
 
 	-- Creates bindings for *new* (polymorphic, overloaded) locals
 	-- in terms of *old* (monomorphic, non-overloaded) ones.
@@ -164,23 +172,23 @@ So the desugarer tries to do a better job:
 					(fm,gm) -> fm
 	..ditto for gp..
 
-	p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND 
-				      in (fm,gm)
+	tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND 
+				       in (fm,gm)
 
 \begin{code}
 -- We keep the invariant that a MonoBinds is only empty 
 -- if it is exactly EmptyMonoBinds
 
-nullMonoBinds :: MonoBinds id pat -> Bool
+nullMonoBinds :: MonoBinds id -> Bool
 nullMonoBinds EmptyMonoBinds	     = True
 nullMonoBinds other_monobind	     = False
 
-andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
+andMonoBinds :: MonoBinds id -> MonoBinds id -> MonoBinds id
 andMonoBinds EmptyMonoBinds mb = mb
 andMonoBinds mb EmptyMonoBinds = mb
 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
 
-andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
+andMonoBindList :: [MonoBinds id] -> MonoBinds id
 andMonoBindList binds
   = loop1 binds
   where
@@ -196,12 +204,11 @@ andMonoBindList binds
 
 
 \begin{code}
-instance (Outputable id, Outputable pat) =>
-		Outputable (MonoBinds id pat) where
+instance OutputableBndr id => Outputable (MonoBinds id) where
     ppr mbind = ppr_monobind mbind
 
 
-ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc
+ppr_monobind :: OutputableBndr id => MonoBinds id -> SDoc
 ppr_monobind EmptyMonoBinds = empty
 ppr_monobind (AndMonoBinds binds1 binds2)
       = ppr_monobind binds1 $$ ppr_monobind binds2
@@ -211,10 +218,7 @@ ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches
       -- ToDo: print infix if appropriate
 
 ppr_monobind (VarMonoBind name expr)
-      = sep [ppr name <+> equals, nest 4 (pprExpr expr)]
-
-ppr_monobind (CoreMonoBind name expr)
-      = sep [ppr name <+> equals, nest 4 (ppr expr)]
+      = sep [pprBndr LetBind name <+> equals, nest 4 (pprExpr expr)]
 
 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
      = sep [ptext SLIT("AbsBinds"),
@@ -223,7 +227,10 @@ ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
 	    brackets (sep (punctuate comma (map ppr exports))),
 	    brackets (interpp'SP (nameSetToList inlines))]
        $$
-       nest 4 (ppr val_binds)
+       nest 4 ( vcat [pprBndr LetBind x | (_,x,_) <- exports]
+			-- Print type signatures
+		$$
+		ppr val_binds )
 \end{code}
 
 %************************************************************************
@@ -263,28 +270,23 @@ data Sig name
 		SrcLoc
 
   | FixSig	(FixitySig name)	-- Fixity declaration
-
-
-data FixitySig name = FixitySig name Fixity SrcLoc 
-
-instance Eq name => Eq (FixitySig name) where
-   (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2
 \end{code}
 
 \begin{code}
 okBindSig :: NameSet -> Sig Name -> Bool
-okBindSig ns (ClassOpSig _ _ _ _)				= False
-okBindSig ns sig = sigForThisGroup ns sig
+okBindSig ns (ClassOpSig _ _ _ _) = False
+okBindSig ns sig		  = sigForThisGroup ns sig
 
-okClsDclSig :: NameSet -> Sig Name -> Bool
-okClsDclSig ns (Sig _ _ _)					  = False
-okClsDclSig ns sig = sigForThisGroup ns sig
+okClsDclSig :: Sig Name -> Bool
+okClsDclSig (Sig _ _ _)       = False
+okClsDclSig (SpecInstSig _ _) = False
+okClsDclSig sig 	      = True	-- All others OK
 
 okInstDclSig :: NameSet -> Sig Name -> Bool
-okInstDclSig ns (Sig _ _ _)					   = False
-okInstDclSig ns (FixSig _)					   = False
-okInstDclSig ns (SpecInstSig _ _)				   = True
-okInstDclSig ns sig = sigForThisGroup ns sig
+okInstDclSig ns (Sig _ _ _)	  = False
+okInstDclSig ns (FixSig _)	  = False
+okInstDclSig ns (SpecInstSig _ _) = True
+okInstDclSig ns sig		  = sigForThisGroup ns sig
 
 sigForThisGroup ns sig 
   = case sigName sig of
@@ -335,7 +337,7 @@ ppr_sig (Sig var ty _)
       = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 
 ppr_sig (ClassOpSig var dm ty _)
-      = sep [ ppr_var var <+> dcolon, 
+      = sep [ pprHsVar var <+> dcolon, 
 	      nest 4 (ppr ty),
 	      nest 4 (pp_dm_comment) ]
       where
@@ -363,10 +365,6 @@ ppr_sig (SpecInstSig ty _)
       = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
 
 ppr_sig (FixSig fix_sig) = ppr fix_sig
-
-
-instance Outputable name => Outputable (FixitySig name) where
-  ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
 \end{code}
 
 Checking for distinct signatures; oh, so boring