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

diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index e39e494..7437f09 100644
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -1,47 +1,34 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 \section[HsBinds]{Abstract syntax: top-level bindings and signatures}
 
 Datatype for: @HsBinds@, @Bind@, @Sig@, @MonoBinds@.
 
 \begin{code}
-#include "HsVersions.h"
-
 module HsBinds where
 
-IMP_Ubiq()
+#include "HsVersions.h"
 
--- friends:
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(HsLoop)	( pprMatches, pprGRHSsAndBinds,
-			  Match, GRHSsAndBinds,
-			  pprExpr, HsExpr )
-#endif
+import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr,
+			       Match,  pprFunBind,
+			       GRHSs,  pprPatBind )
 
-import HsPragmas	( GenPragmas, ClassOpPragmas )
+-- friends:
+import HsImpExp		( pprHsVar )
+import HsPat		( Pat )
 import HsTypes		( HsType )
-import CoreSyn		( SYN_IE(CoreExpr) )
+import PprCore		( {- instance Outputable (Expr a) -} )
 
 --others:
-import Id		( SYN_IE(DictVar), SYN_IE(Id), GenId )
-import Name		( OccName, NamedThing(..) )
-import Outputable	( interpp'SP, ifnotPprForUser, pprQuote,
-			  Outputable(..){-instance * (,)-}
-			)
-import PprCore		--( GenCoreExpr {- instance Outputable -} )
-import PprType		( GenTyVar {- instance Outputable -} )
-import Pretty
-import Bag
-import SrcLoc		( SrcLoc{-instances-} )
-import TyVar		( GenTyVar{-instances-} )
-import Unique		( Unique {- instance Eq -} )
-
-#if __GLASGOW_HASKELL__ >= 202
-import {-# SOURCE #-} HsExpr    ( pprExpr, HsExpr )
-import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSsAndBinds, GRHSsAndBinds )
-#endif
-
+import Name		( Name )
+import PrelNames	( isUnboundName )
+import NameSet		( NameSet, elemNameSet, nameSetToList )
+import BasicTypes	( RecFlag(..), FixitySig(..), Activation(..), IPName )
+import Outputable	
+import SrcLoc		( SrcLoc )
+import Var		( TyVar )
+import Class            ( DefMeth (..) )
 \end{code}
 
 %************************************************************************
@@ -59,50 +46,59 @@ grammar.
 Collections of bindings, created by dependency analysis and translation:
 
 \begin{code}
-data HsBinds tyvar uvar id pat		-- binders and bindees
+data HsBinds id		-- binders and bindees
   = EmptyBinds
-
-  | ThenBinds	(HsBinds tyvar uvar id pat)
-		(HsBinds tyvar uvar id pat)
-
-  | MonoBind 	(MonoBinds tyvar uvar id pat)
-		[Sig id]		-- Empty on typechecker output
-		RecFlag
-
-type RecFlag = Bool
-recursive    = True
-nonRecursive = False
+  | 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 tyvar uvar 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 :: RecFlag -> MonoBinds id -> HsBinds id
+mkMonoBind _      EmptyMonoBinds  = EmptyBinds
+mkMonoBind is_rec mbinds 	  = MonoBind mbinds [] is_rec
 \end{code}
 
 \begin{code}
-instance (Outputable pat, NamedThing id, Outputable id,
-	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
-		Outputable (HsBinds tyvar uvar id pat) where
-
-    ppr sty binds = pprQuote sty (\ sty -> ppr_binds sty binds)
-
-ppr_binds sty EmptyBinds = empty
-ppr_binds sty (ThenBinds binds1 binds2)
-     = ($$) (ppr_binds sty binds1) (ppr_binds sty binds2)
-ppr_binds sty (MonoBind bind sigs is_rec)
-     = vcat [
-	ifnotPprForUser sty (ptext rec_str),
-	if null sigs
-	  then empty
-	  else vcat (map (ppr sty) sigs),
-	ppr sty bind
+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),
+	     ppr bind
        ]
      where
-       rec_str | is_rec    = SLIT("{- rec -}")
-               | otherwise = SLIT("{- nonrec -}")
+       ppr_isrec = getPprStyle $ \ sty -> 
+		   if userStyle sty then empty else
+		   case is_rec of
+		   	Recursive    -> ptext SLIT("{- rec -}")
+			NonRecursive -> ptext SLIT("{- nonrec -}")
 \end{code}
 
 %************************************************************************
@@ -114,32 +110,38 @@ ppr_binds sty (MonoBind bind sigs is_rec)
 Global bindings (where clauses)
 
 \begin{code}
-data MonoBinds tyvar uvar id pat
+data MonoBinds id
   = EmptyMonoBinds
 
-  | AndMonoBinds    (MonoBinds tyvar uvar id pat)
-		    (MonoBinds tyvar uvar id pat)
-
-  | PatMonoBind     pat
-		    (GRHSsAndBinds tyvar uvar id pat)
+  | AndMonoBinds    (MonoBinds id)
+		    (MonoBinds id)
+
+  | FunMonoBind     id		-- Used for both functions 	f x = e
+				-- and variables		f = \x -> e
+				-- Reason: the Match stuff lets us have an optional
+				--	   result type sig	f :: a->a = ...mentions a...
+				--
+				-- This also means that instance decls can only have
+				-- FunMonoBinds, so if you change this, you'll need to
+				-- change e.g. rnMethodBinds
+		    Bool		-- True => infix declaration
+		    [Match id]
 		    SrcLoc
 
-  | FunMonoBind     id
-		    Bool			-- True => infix declaration
-		    [Match tyvar uvar id pat]	-- must have at least one Match
+  | PatMonoBind     (Pat id)	-- The pattern is never a simple variable;
+				-- That case is done by FunMonoBind
+		    (GRHSs id)
 		    SrcLoc
 
   | VarMonoBind	    id			-- TRANSLATION
-		    (HsExpr tyvar uvar 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
-		(MonoBinds tyvar uvar id pat)	 -- The "business end"
+  | 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)      -- The "business end"
 
 	-- Creates bindings for *new* (polymorphic, overloaded) locals
 	-- in terms of *old* (monomorphic, non-overloaded) ones.
@@ -170,50 +172,65 @@ 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}
-nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool
+-- We keep the invariant that a MonoBinds is only empty 
+-- if it is exactly EmptyMonoBinds
 
+nullMonoBinds :: MonoBinds id -> Bool
 nullMonoBinds EmptyMonoBinds	     = True
-nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
 nullMonoBinds other_monobind	     = False
 
-andMonoBinds :: [MonoBinds tyvar uvar id pat] -> MonoBinds tyvar uvar id pat
-andMonoBinds binds = foldr AndMonoBinds EmptyMonoBinds binds
+andMonoBinds :: MonoBinds id -> MonoBinds id -> MonoBinds id
+andMonoBinds EmptyMonoBinds mb = mb
+andMonoBinds mb EmptyMonoBinds = mb
+andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
+
+andMonoBindList :: [MonoBinds id] -> MonoBinds id
+andMonoBindList binds
+  = loop1 binds
+  where
+    loop1 [] = EmptyMonoBinds
+    loop1 (EmptyMonoBinds : binds) = loop1 binds
+    loop1 (b:bs) = loop2 b bs
+
+	-- acc is non-empty
+    loop2 acc [] = acc
+    loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
+    loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
 \end{code}
 
-\begin{code}
-instance (NamedThing id, Outputable id, Outputable pat,
-	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
-		Outputable (MonoBinds tyvar uvar id pat) where
-    ppr sty mbind = pprQuote sty (\ sty -> ppr_monobind sty mbind)
 
+\begin{code}
+instance OutputableBndr id => Outputable (MonoBinds id) where
+    ppr mbind = ppr_monobind mbind
 
-ppr_monobind sty EmptyMonoBinds = empty
-ppr_monobind sty (AndMonoBinds binds1 binds2)
-      = ($$) (ppr_monobind sty binds1) (ppr_monobind sty binds2)
 
-ppr_monobind sty (PatMonoBind pat grhss_n_binds locn)
-      = sep [ppr sty pat, nest 4 (pprGRHSsAndBinds sty False grhss_n_binds)]
+ppr_monobind :: OutputableBndr id => MonoBinds id -> SDoc
+ppr_monobind EmptyMonoBinds = empty
+ppr_monobind (AndMonoBinds binds1 binds2)
+      = ppr_monobind binds1 $$ ppr_monobind binds2
 
-ppr_monobind sty (FunMonoBind fun inf matches locn)
-      = pprMatches sty (False, ppr sty fun) matches
+ppr_monobind (PatMonoBind pat grhss locn)	= pprPatBind pat grhss
+ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches
       -- ToDo: print infix if appropriate
 
-ppr_monobind sty (VarMonoBind name expr)
-      = sep [ppr sty name <+> equals, nest 4 (pprExpr sty expr)]
-
-ppr_monobind sty (CoreMonoBind name expr)
-      = sep [ppr sty name <+> equals, nest 4 (ppr sty expr)]
-
-ppr_monobind sty (AbsBinds tyvars dictvars exports val_binds)
-     = ($$) (sep [ptext SLIT("AbsBinds"),
-		  brackets (interpp'SP sty tyvars),
-		  brackets (interpp'SP sty dictvars),
-		  brackets (interpp'SP sty exports)])
-	       (nest 4 (ppr sty val_binds))
+ppr_monobind (VarMonoBind name expr)
+      = sep [pprBndr LetBind name <+> equals, nest 4 (pprExpr expr)]
+
+ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
+     = sep [ptext SLIT("AbsBinds"),
+	    brackets (interpp'SP tyvars),
+	    brackets (interpp'SP dictvars),
+	    brackets (sep (punctuate comma (map ppr exports))),
+	    brackets (interpp'SP (nameSetToList inlines))]
+       $$
+       nest 4 ( vcat [pprBndr LetBind x | (_,x,_) <- exports]
+			-- Print type signatures
+		$$
+		ppr val_binds )
 \end{code}
 
 %************************************************************************
@@ -233,56 +250,136 @@ data Sig name
 		(HsType name)
 		SrcLoc
 
-  | ClassOpSig	name			-- Selector name
-		(Maybe name)		-- Default-method name (if any)
+  | ClassOpSig	name		-- Selector name
+                (DefMeth name)	-- Default-method info
+				-- See "THE NAMING STORY" in HsDecls
 		(HsType name)
 		SrcLoc
 
   | SpecSig 	name		-- specialise a function or datatype ...
-		(HsType name) -- ... to these types
-		(Maybe name)	-- ... maybe using this as the code for it
+		(HsType name)	-- ... to these types
 		SrcLoc
 
-  | InlineSig	name		  -- INLINE f
+  | InlineSig	Bool		-- True <=> INLINE f, False <=> NOINLINE f
+	 	name		-- Function name
+		Activation	-- When inlining is *active*
 		SrcLoc
 
-  | DeforestSig name            -- Deforest using this function definition
-	      	SrcLoc
+  | SpecInstSig (HsType name)	-- (Class tys); should be a specialisation of the 
+				-- current instance decl
+		SrcLoc
 
-  | MagicUnfoldingSig
-		name		-- Associate the "name"d function with
-		FAST_STRING	-- the compiler-builtin unfolding (known
-		SrcLoc		-- by the String name)
+  | FixSig	(FixitySig name)	-- Fixity declaration
 \end{code}
 
 \begin{code}
-instance (NamedThing name, Outputable name) => Outputable (Sig name) where
-    ppr sty sig = pprQuote sty (\ sty -> ppr_sig sty sig)
-
+okBindSig :: NameSet -> Sig Name -> Bool
+okBindSig ns (ClassOpSig _ _ _ _) = False
+okBindSig 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
+
+sigForThisGroup ns sig 
+  = case sigName sig of
+	Nothing 		 -> False
+	Just n | isUnboundName n -> True	-- Don't complain about an unbound name again
+	       | otherwise 	 -> n `elemNameSet` ns
+
+sigName :: Sig name -> Maybe name
+sigName (Sig         n _ _)        = Just n
+sigName (ClassOpSig  n _ _ _)      = Just n
+sigName (SpecSig     n _ _)        = Just n
+sigName (InlineSig _ n _ _)        = Just n
+sigName (FixSig (FixitySig n _ _)) = Just n
+sigName other			   = Nothing
+
+isFixitySig :: Sig name -> Bool
+isFixitySig (FixSig _) = True
+isFixitySig _	       = False
+
+isClassOpSig :: Sig name -> Bool
+isClassOpSig (ClassOpSig _ _ _ _) = True
+isClassOpSig _			  = False
+
+isPragSig :: Sig name -> Bool
+	-- Identifies pragmas 
+isPragSig (SpecSig _ _ _)     = True
+isPragSig (InlineSig _ _ _ _) = True
+isPragSig (SpecInstSig _ _)   = True
+isPragSig other		      = False
+\end{code}
 
-ppr_sig sty (Sig var ty _)
-      = sep [ppr sty var <+> ptext SLIT("::"),
-	     nest 4 (ppr sty ty)]
+\begin{code}
+hsSigDoc (Sig        _ _ loc) 	      = (ptext SLIT("type signature"),loc)
+hsSigDoc (ClassOpSig _ _ _ loc)       = (ptext SLIT("class-method type signature"), loc)
+hsSigDoc (SpecSig    _ _ loc) 	      = (ptext SLIT("SPECIALISE pragma"),loc)
+hsSigDoc (InlineSig True  _ _ loc)    = (ptext SLIT("INLINE pragma"),loc)
+hsSigDoc (InlineSig False _ _ loc)    = (ptext SLIT("NOINLINE pragma"),loc)
+hsSigDoc (SpecInstSig _ loc)	      = (ptext SLIT("SPECIALISE instance pragma"),loc)
+hsSigDoc (FixSig (FixitySig _ _ loc)) = (ptext SLIT("fixity declaration"), loc)
+\end{code}
 
-ppr_sig sty (ClassOpSig var _ ty _)
-      = sep [ppr sty (getOccName var) <+> ptext SLIT("::"),
-	     nest 4 (ppr sty ty)]
+\begin{code}
+instance (Outputable name) => Outputable (Sig name) where
+    ppr sig = ppr_sig sig
 
-ppr_sig sty (DeforestSig var _)
-      = hsep [text "{-# DEFOREST", ppr sty var, text "#-}"]
+ppr_sig :: Outputable name => Sig name -> SDoc
+ppr_sig (Sig var ty _)
+      = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 
-ppr_sig sty (SpecSig var ty using _)
-      = sep [ hsep [text "{-# SPECIALIZE", ppr sty var, ptext SLIT("::")],
-	      nest 4 (hsep [ppr sty ty, pp_using using, text "#-}"])
-	]
+ppr_sig (ClassOpSig var dm ty _)
+      = sep [ pprHsVar var <+> dcolon, 
+	      nest 4 (ppr ty),
+	      nest 4 (pp_dm_comment) ]
       where
-	pp_using Nothing   = empty
-	pp_using (Just me) = hsep [char '=', ppr sty me]
+	pp_dm = case dm of 
+		  DefMeth _  -> equals 	-- Default method indicator
+		  GenDefMeth -> semi    -- Generic method indicator
+		  NoDefMeth  -> empty   -- No Method at all
+	pp_dm_comment = case dm of 
+		  DefMeth _  -> text "{- has default method -}"
+		  GenDefMeth -> text "{- has generic method -}"
+		  NoDefMeth  -> empty   -- No Method at all
+
+ppr_sig (SpecSig var ty _)
+      = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
+	      nest 4 (ppr ty <+> text "#-}")
+	]
 
-ppr_sig sty (InlineSig var _)
-        = hsep [text "{-# INLINE", ppr sty var, text "#-}"]
+ppr_sig (InlineSig True var phase _)
+      = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"]
 
-ppr_sig sty (MagicUnfoldingSig var str _)
-      = hsep [text "{-# MAGIC_UNFOLDING", ppr sty var, ptext str, text "#-}"]
+ppr_sig (InlineSig False var phase _)
+      = hsep [text "{-# NOINLINE", ppr phase, ppr var, text "#-}"]
+
+ppr_sig (SpecInstSig ty _)
+      = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
+
+ppr_sig (FixSig fix_sig) = ppr fix_sig
 \end{code}
 
+Checking for distinct signatures; oh, so boring
+
+
+\begin{code}
+eqHsSig :: Sig Name -> Sig Name -> Bool
+eqHsSig (Sig n1 _ _)         (Sig n2 _ _)          = n1 == n2
+eqHsSig (InlineSig b1 n1 _ _)(InlineSig b2 n2 _ _) = b1 == b2 && n1 == n2
+
+eqHsSig (SpecInstSig ty1 _)  (SpecInstSig ty2 _)  = ty1 == ty2
+eqHsSig (SpecSig n1 ty1 _)   (SpecSig n2 ty2 _)   =
+    -- may have many specialisations for one value;
+    -- but not ones that are exactly the same...
+    (n1 == n2) && (ty1 == ty2)
+
+eqHsSig _other1 _other2 = False
+\end{code}