X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsBinds.lhs;h=a9a114d4a30cb05509c27f0621c520eb824b7e6b;hb=94ff1ec1546169fc839b2318c0d141f3089d3e26;hp=2c2a687d700314182ae0bf9188df52cad5d5b291;hpb=7a3bd641457666e10d0a47be9f22762e03defbf0;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs
index 2c2a687..a9a114d 100644
--- a/ghc/compiler/hsSyn/HsBinds.lhs
+++ b/ghc/compiler/hsSyn/HsBinds.lhs
@@ -1,39 +1,30 @@
 %
-% (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"
+
+import {-# SOURCE #-} HsExpr    ( pprExpr, HsExpr )
+import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSs, GRHSs )
 
 -- friends:
-IMPORT_DELOOPER(HsLoop)
-import HsMatches	( pprMatches, pprGRHSsAndBinds,
-			  Match, GRHSsAndBinds )
-import HsPat		( collectPatBinders, InPat )
-import HsPragmas	( GenPragmas, ClassOpPragmas )
 import HsTypes		( HsType )
-import CoreSyn		( SYN_IE(CoreExpr) )
+import CoreSyn		( CoreExpr )
+import PprCore		()	   -- Instances for Outputable
 
 --others:
-import Id		( SYN_IE(DictVar), SYN_IE(Id), GenId )
-import Name		( pprNonSym, getOccName, OccName )
-import Outputable	( interpp'SP, ifnotPprForUser,
-			  Outputable(..){-instance * (,)-}
-			)
-import PprCore		( GenCoreExpr {- instance Outputable -} )
-import PprType		( GenTyVar {- instance Outputable -} )
-import Pretty
+import Id		( Id )
+import BasicTypes	( RecFlag(..), Fixity )
+import Outputable	
 import Bag
-import SrcLoc		( SrcLoc{-instances-} )
-import TyVar		( GenTyVar{-instances-} )
-import Unique		( Unique {- instance Eq -} )
+import SrcLoc		( SrcLoc )
+import Var		( TyVar )
 \end{code}
 
 %************************************************************************
@@ -51,26 +42,79 @@ grammar.
 Collections of bindings, created by dependency analysis and translation:
 
 \begin{code}
-data HsBinds tyvar uvar id pat		-- binders and bindees
+data HsBinds id pat		-- binders and bindees
   = EmptyBinds
 
-  | ThenBinds	(HsBinds tyvar uvar id pat)
-		(HsBinds tyvar uvar id pat)
+  | ThenBinds	(HsBinds id pat)
+		(HsBinds id pat)
+
+  | MonoBind 	(MonoBinds id pat)
+		[Sig id]		-- Empty on typechecker output
+		RecFlag
+\end{code}
+
+\begin{code}
+nullBinds :: HsBinds id pat -> Bool
+
+nullBinds EmptyBinds		= True
+nullBinds (ThenBinds b1 b2)	= nullBinds b1 && nullBinds b2
+nullBinds (MonoBind b _ _)	= nullMonoBinds b
+\end{code}
+
+\begin{code}
+instance (Outputable pat, Outputable id) =>
+		Outputable (HsBinds id pat) where
+    ppr binds = ppr_binds binds
+
+ppr_binds EmptyBinds = empty
+ppr_binds (ThenBinds binds1 binds2)
+     = ($$) (ppr_binds binds1) (ppr_binds binds2)
+ppr_binds (MonoBind bind sigs is_rec)
+     = vcat [ifNotPprForUser (ptext rec_str),
+     	     vcat (map ppr sigs),
+	     ppr bind
+       ]
+     where
+       rec_str = case is_rec of
+		   Recursive    -> SLIT("{- rec -}")
+		   NonRecursive -> SLIT("{- nonrec -}")
+\end{code}
+
+%************************************************************************
+%*									*
+\subsection{Bindings: @MonoBinds@}
+%*									*
+%************************************************************************
+
+Global bindings (where clauses)
+
+\begin{code}
+data MonoBinds id pat
+  = EmptyMonoBinds
+
+  | AndMonoBinds    (MonoBinds id pat)
+		    (MonoBinds id pat)
+
+  | PatMonoBind     pat
+		    (GRHSs id pat)
+		    SrcLoc
 
-  | SingleBind	(Bind  tyvar uvar id pat)
+  | FunMonoBind     id
+		    Bool			-- True => infix declaration
+		    [Match id pat]
+		    SrcLoc
+
+  | VarMonoBind	    id			-- TRANSLATION
+		    (HsExpr id pat)
 
-  | BindWith		-- Bind with a type signature.
-			-- These appear only on typechecker input
-			-- (HsType [in Sigs] can't appear on output)
-		(Bind tyvar uvar id pat)
-		[Sig id]
+  | CoreMonoBind    id			-- TRANSLATION
+		    CoreExpr		-- No zonking; this is a final CoreExpr with Ids and Types!
 
   | AbsBinds			-- Binds abstraction; TRANSLATION
-		[tyvar]
-		[id]		-- Dicts
-		[(id, id)]	-- (old, new) pairs
-		[(id, HsExpr tyvar uvar id pat)]	-- local dictionaries
-		(Bind tyvar uvar id pat)		-- "the business end"
+		[TyVar]	  -- Type variables
+		[id]			  -- Dicts
+		[([TyVar], id, id)]  -- (type variables, polymorphic, momonmorphic) triples
+		(MonoBinds id pat)      -- The "business end"
 
 	-- Creates bindings for *new* (polymorphic, overloaded) locals
 	-- in terms of *old* (monomorphic, non-overloaded) ones.
@@ -80,36 +124,77 @@ data HsBinds tyvar uvar id pat		-- binders and bindees
 	--  of this last construct.)
 \end{code}
 
+What AbsBinds means
+~~~~~~~~~~~~~~~~~~~
+	 AbsBinds tvs
+		  [d1,d2]
+		  [(tvs1, f1p, f1m), 
+		   (tvs2, f2p, f2m)]
+		  BIND
+means
+
+	f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND 
+				      in fm
+
+	gp = ...same again, with gm instead of fm
+
+This is a pretty bad translation, because it duplicates all the bindings.
+So the desugarer tries to do a better job:
+
+	fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
+					(fm,gm) -> fm
+	..ditto for gp..
+
+	p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND 
+				      in (fm,gm)
+
 \begin{code}
-nullBinds :: HsBinds tyvar uvar id pat -> Bool
+nullMonoBinds :: MonoBinds id pat -> Bool
 
-nullBinds EmptyBinds		= True
-nullBinds (ThenBinds b1 b2)	= nullBinds b1 && nullBinds b2
-nullBinds (SingleBind b)	= nullBind b
-nullBinds (BindWith b _)	= nullBind b
-nullBinds (AbsBinds _ _ _ ds b)	= null ds && nullBind b
+nullMonoBinds EmptyMonoBinds	     = True
+nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
+nullMonoBinds other_monobind	     = False
+
+andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
+andMonoBinds EmptyMonoBinds mb = mb
+andMonoBinds mb EmptyMonoBinds = mb
+andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
+
+andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
+andMonoBindList binds = foldr AndMonoBinds EmptyMonoBinds binds
 \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 EmptyBinds = ppNil
-    ppr sty (ThenBinds binds1 binds2)
-     = ppAbove (ppr sty binds1) (ppr sty binds2)
-    ppr sty (SingleBind bind) = ppr sty bind
-    ppr sty (BindWith bind sigs)
-     = ppAbove (if null sigs 
-		then ppNil
-		else ppAboves (map (ppr sty) sigs))
-	       (ppr sty bind)
-    ppr sty (AbsBinds tyvars dictvars local_pairs dict_binds val_binds)
-     = ppAbove (ppSep [ppPStr SLIT("AbsBinds"),
-		      ppBesides[ppLbrack, interpp'SP sty tyvars, ppRbrack],
-		      ppBesides[ppLbrack, interpp'SP sty dictvars, ppRbrack],
-		      ppBesides[ppLbrack, interpp'SP sty local_pairs, ppRbrack]])
-	    (ppNest 4 (ppAbove (ppAboves (map (ppr sty) dict_binds)) (ppr sty val_binds)))
+instance (Outputable id, Outputable pat) =>
+		Outputable (MonoBinds id pat) where
+    ppr mbind = ppr_monobind mbind
+
+
+ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc
+ppr_monobind EmptyMonoBinds = empty
+ppr_monobind (AndMonoBinds binds1 binds2)
+      = ppr_monobind binds1 $$ ppr_monobind binds2
+
+ppr_monobind (PatMonoBind pat grhss locn)
+      = sep [ppr pat, nest 4 (pprGRHSs False grhss)]
+
+ppr_monobind (FunMonoBind fun inf matches locn)
+      = pprMatches (False, ppr 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)]
+
+ppr_monobind (AbsBinds tyvars dictvars exports val_binds)
+     = sep [ptext SLIT("AbsBinds"),
+	    brackets (interpp'SP tyvars),
+	    brackets (interpp'SP dictvars),
+	    brackets (interpp'SP exports)]
+       $$
+       nest 4 (ppr val_binds)
 \end{code}
 
 %************************************************************************
@@ -129,193 +214,83 @@ data Sig name
 		(HsType name)
 		SrcLoc
 
-  | ClassOpSig	name		-- class-op sigs have different pragmas
+  | ClassOpSig	name		-- Selector name
+		(Maybe name)	-- Default-method name (if any)
 		(HsType name)
-		(ClassOpPragmas name)	-- only interface ones have pragmas
 		SrcLoc
 
   | SpecSig 	name		-- specialise a function or datatype ...
-		(HsType name) -- ... to these types
+		(HsType name)	-- ... to these types
 		(Maybe name)	-- ... maybe using this as the code for it
 		SrcLoc
 
-  | InlineSig	name		  -- INLINE f
+  | InlineSig	name		-- INLINE f
 		SrcLoc
 
-  | DeforestSig name            -- Deforest using this function definition
-	      	SrcLoc
-
-  | MagicUnfoldingSig
-		name		-- Associate the "name"d function with
-		FAST_STRING	-- the compiler-builtin unfolding (known
-		SrcLoc		-- by the String name)
-\end{code}
-
-\begin{code}
-instance (NamedThing name, Outputable name) => Outputable (Sig name) where
-    ppr sty (Sig var ty _)
-      = ppHang (ppCat [pprNonSym sty var, ppPStr SLIT("::")])
-	     4 (ppr sty ty)
-
-    ppr sty (ClassOpSig var ty pragmas _)
-      = ppHang (ppCat [ppr sty (getOccName var), ppPStr SLIT("::")])
-	     4 (ppHang (ppr sty ty)
-		     4 (ifnotPprForUser sty (ppr sty pragmas)))
-
-    ppr sty (DeforestSig var _)
-      = ppHang (ppCat [ppStr "{-# DEFOREST", pprNonSym sty var])
-		   4 (ppStr "#-}")
-
-    ppr sty (SpecSig var ty using _)
-      = ppHang (ppCat [ppPStr SLIT("{-# SPECIALIZE"), pprNonSym sty var, ppPStr SLIT("::")])
-	     4 (ppCat [ppr sty ty, pp_using using, ppPStr SLIT("#-}")])
-      where
-	pp_using Nothing   = ppNil
-	pp_using (Just me) = ppCat [ppChar '=', ppr sty me]
+  | NoInlineSig	name		-- NOINLINE f
+		SrcLoc
 
-    ppr sty (InlineSig var _)
-      = ppCat [ppPStr SLIT("{-# INLINE"), pprNonSym sty var, ppPStr SLIT("#-}")]
+  | SpecInstSig (HsType name)	-- (Class tys); should be a specialisation of the 
+				-- current instance decl
+		SrcLoc
 
-    ppr sty (MagicUnfoldingSig var str _)
-      = ppCat [ppPStr SLIT("{-# MAGIC_UNFOLDING"), pprNonSym sty var, ppPStr str, ppPStr SLIT("#-}")]
-\end{code}
+  | FixSig	(FixitySig name)		-- Fixity declaration
 
-%************************************************************************
-%*									*
-\subsection{Binding: @Bind@}
-%*									*
-%************************************************************************
 
-\begin{code}
-data Bind tyvar uvar id pat		-- binders and bindees
-  = EmptyBind	-- because it's convenient when parsing signatures
-  | NonRecBind	(MonoBinds tyvar uvar id pat)
-  | RecBind	(MonoBinds tyvar uvar id pat)
+data FixitySig name  = FixitySig name Fixity SrcLoc
 \end{code}
 
 \begin{code}
-nullBind :: Bind tyvar uvar id pat -> Bool
-
-nullBind EmptyBind	 = True
-nullBind (NonRecBind bs) = nullMonoBinds bs
-nullBind (RecBind bs)	 = nullMonoBinds bs
+sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name]
+sigsForMe f sigs
+  = filter sig_for_me sigs
+  where
+    sig_for_me (Sig         n _ _)    	  = f n
+    sig_for_me (ClassOpSig  n _ _ _)  	  = f n
+    sig_for_me (SpecSig     n _ _ _)  	  = f n
+    sig_for_me (InlineSig   n     _)  	  = f n  
+    sig_for_me (NoInlineSig n     _)  	  = f n  
+    sig_for_me (SpecInstSig _ _)      	  = False
+    sig_for_me (FixSig (FixitySig n _ _)) = f n
+
+nonFixitySigs :: [Sig name] -> [Sig name]
+nonFixitySigs sigs = filter not_fix sigs
+ 		   where
+		     not_fix (FixSig _) = False
+		     not_fix other	= True
 \end{code}
 
 \begin{code}
-bindIsRecursive :: Bind tyvar uvar id pat -> Bool
+instance (Outputable name) => Outputable (Sig name) where
+    ppr sig = ppr_sig sig
 
-bindIsRecursive EmptyBind	= False
-bindIsRecursive (NonRecBind _)	= False
-bindIsRecursive (RecBind _)	= True
-\end{code}
+instance Outputable name => Outputable (FixitySig name) where
+  ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
 
-\begin{code}
-instance (NamedThing id, Outputable id, Outputable pat,
-	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
-		Outputable (Bind tyvar uvar id pat) where
-    ppr sty EmptyBind = ppNil
-    ppr sty (NonRecBind binds)
-     = ppAbove (ifnotPprForUser sty (ppStr "{- nonrec -}"))
-	       (ppr sty binds)
-    ppr sty (RecBind binds)
-     = ppAbove (ifnotPprForUser sty (ppStr "{- rec -}"))
-	       (ppr sty binds)
-\end{code}
 
-%************************************************************************
-%*									*
-\subsection{Bindings: @MonoBinds@}
-%*									*
-%************************************************************************
+ppr_sig (Sig var ty _)
+      = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 
-Global bindings (where clauses)
+ppr_sig (ClassOpSig var _ ty _)
+      = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 
-\begin{code}
-data MonoBinds tyvar uvar id pat
-  = EmptyMonoBinds
-  | AndMonoBinds    (MonoBinds tyvar uvar id pat)
-		    (MonoBinds tyvar uvar id pat)
-  | PatMonoBind     pat
-		    (GRHSsAndBinds tyvar uvar id pat)
-		    SrcLoc
-  | FunMonoBind     id
-		    Bool			-- True => infix declaration
-		    [Match tyvar uvar id pat]	-- must have at least one Match
-		    SrcLoc
+ppr_sig (SpecSig var ty using _)
+      = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
+	      nest 4 (hsep [ppr ty, pp_using using, text "#-}"])
+	]
+      where
+	pp_using Nothing   = empty
+	pp_using (Just me) = hsep [char '=', ppr me]
 
-  | VarMonoBind	    id			-- TRANSLATION
-		    (HsExpr tyvar uvar id pat)
+ppr_sig (InlineSig var _)
+        = hsep [text "{-# INLINE", ppr var, text "#-}"]
 
-  | CoreMonoBind    id			-- TRANSLATION
-		    CoreExpr		-- No zonking; this is a final CoreExpr with Ids and Types!
-\end{code}
+ppr_sig (NoInlineSig var _)
+        = hsep [text "{-# NOINLINE", ppr var, text "#-}"]
 
-\begin{code}
-nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool
+ppr_sig (SpecInstSig ty _)
+      = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
 
-nullMonoBinds EmptyMonoBinds	     = True
-nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
-nullMonoBinds other_monobind	     = False
+ppr_sig (FixSig fix_sig) = ppr fix_sig
 \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 EmptyMonoBinds = ppNil
-    ppr sty (AndMonoBinds binds1 binds2)
-      = ppAbove (ppr sty binds1) (ppr sty binds2)
-
-    ppr sty (PatMonoBind pat grhss_n_binds locn)
-      = ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)
-
-    ppr sty (FunMonoBind fun inf matches locn)
-      = pprMatches sty (False, pprNonSym sty fun) matches
-      -- ToDo: print infix if appropriate
-
-    ppr sty (VarMonoBind name expr)
-      = ppHang (ppCat [pprNonSym sty name, ppEquals]) 4 (ppr sty expr)
-
-    ppr sty (CoreMonoBind name expr)
-      = ppHang (ppCat [pprNonSym sty name, ppEquals]) 4 (ppr sty expr)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{Collecting binders from @HsBinds@}
-%*									*
-%************************************************************************
-
-Get all the binders in some @MonoBinds@, IN THE ORDER OF
-APPEARANCE; e.g., in:
-\begin{verbatim}
-...
-where
-  (x, y) = ...
-  f i j  = ...
-  [a, b] = ...
-\end{verbatim}
-it should return @[x, y, f, a, b]@ (remember, order important).
-
-\begin{code}
-collectTopBinders :: HsBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
-collectTopBinders EmptyBinds     = emptyBag
-collectTopBinders (SingleBind b) = collectBinders b
-collectTopBinders (BindWith b _) = collectBinders b
-collectTopBinders (ThenBinds b1 b2)
- = collectTopBinders b1 `unionBags` collectTopBinders b2
-
-collectBinders :: Bind tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
-collectBinders EmptyBind 	      = emptyBag
-collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds
-collectBinders (RecBind monobinds)    = collectMonoBinders monobinds
-
-collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
-collectMonoBinders EmptyMonoBinds		       = emptyBag
-collectMonoBinders (PatMonoBind pat grhss_w_binds loc) = listToBag (map (\v->(v,loc)) (collectPatBinders pat))
-collectMonoBinders (FunMonoBind f _ matches loc)       = unitBag (f,loc)
-collectMonoBinders (VarMonoBind v expr) 	       = error "collectMonoBinders"
-collectMonoBinders (CoreMonoBind v expr) 	       = error "collectMonoBinders"
-collectMonoBinders (AndMonoBinds bs1 bs2)
- = collectMonoBinders bs1 `unionBags` collectMonoBinders bs2
-\end{code}