X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsSyn.lhs;h=7f5ca52b8e3dde4a855e464687c8edc8a7cc8a3d;hb=d482ad51c9051d6eb9fbcafd90362949db29f374;hp=c2feb2af26a4ce2d4782cba58d55b739e0d20686;hpb=1c62b517711ac232a8024d91fd4b317a6804d28e;p=ghc-hetmet.git

diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs
index c2feb2a..7f5ca52 100644
--- a/ghc/compiler/hsSyn/HsSyn.lhs
+++ b/ghc/compiler/hsSyn/HsSyn.lhs
@@ -9,11 +9,9 @@ therefore, is almost nothing but re-exporting.
 
 \begin{code}
 module HsSyn (
-
 	-- NB: don't reexport HsCore
 	-- this module tells about "real Haskell"
 
-	module HsSyn,
 	module HsBinds,
 	module HsDecls,
 	module HsExpr,
@@ -23,9 +21,11 @@ module HsSyn (
 	module HsTypes,
 	Fixity, NewOrData, 
 
-	collectHsBinders, collectLocatedHsBinders, 
+	HsModule(..), hsModule, hsImports,
+	collectStmtsBinders,
+	collectHsBinders,   collectLocatedHsBinders, 
 	collectMonoBinders, collectLocatedMonoBinders,
-	hsModuleName, hsModuleImports
+	collectSigTysFromHsBinds, collectSigTysFromMonoBinds
      ) where
 
 #include "HsVersions.h"
@@ -44,14 +44,14 @@ import BasicTypes	( Fixity, Version, NewOrData )
 import Name		( NamedThing )
 import Outputable
 import SrcLoc		( SrcLoc )
-import Module		( ModuleName )
+import Module		( Module )
 \end{code}
 
 All we actually declare here is the top-level structure for a module.
 \begin{code}
-data HsModule name pat
+data HsModule name
   = HsModule
-	ModuleName		-- module name
+	Module
 	(Maybe Version)		-- source interface version number
 	(Maybe [IE name])	-- export list; Nothing => export everything
 				-- Just [] => export *nothing* (???)
@@ -60,14 +60,14 @@ data HsModule name pat
 				-- imported interfaces early on, adding that
 				-- info to TyDecls/etc; so this list is
 				-- often empty, downstream.
-	[HsDecl name pat]	-- Type, class, value, and interface signature decls
+	[HsDecl name]	-- Type, class, value, and interface signature decls
 	(Maybe DeprecTxt)	-- reason/explanation for deprecation of this module
 	SrcLoc
 \end{code}
 
 \begin{code}
-instance (NamedThing name, Outputable name, Outputable pat)
-	=> Outputable (HsModule name pat) where
+instance (NamedThing name, OutputableBndr name)
+	=> Outputable (HsModule name) where
 
     ppr (HsModule name iface_version exports imports
 		      decls deprec src_loc)
@@ -92,8 +92,8 @@ instance (NamedThing name, Outputable name, Outputable pat)
 	pp_nonnull [] = empty
 	pp_nonnull xs = vcat (map ppr xs)
 
-hsModuleName    (HsModule mod_name _ _ _ _ _ _) = mod_name
-hsModuleImports (HsModule mod_name vers exports imports decls deprec src_loc) = imports
+hsModule  (HsModule mod _ _ _ _ _ _) = mod
+hsImports (HsModule mod vers exports imports decls deprec src_loc) = imports
 \end{code}
 
 
@@ -117,21 +117,22 @@ where
 it should return @[x, y, f, a, b]@ (remember, order important).
 
 \begin{code}
-collectLocatedHsBinders :: HsBinds name (InPat name) -> [(name,SrcLoc)]
+collectLocatedHsBinders :: HsBinds name -> [(name,SrcLoc)]
+-- Used at top level only; so no need for an IPBinds case
 collectLocatedHsBinders EmptyBinds = []
 collectLocatedHsBinders (MonoBind b _ _) 
  = collectLocatedMonoBinders b
 collectLocatedHsBinders (ThenBinds b1 b2)
  = collectLocatedHsBinders b1 ++ collectLocatedHsBinders b2
 
-collectHsBinders :: HsBinds name (InPat name) -> [name]
-collectHsBinders EmptyBinds = []
-collectHsBinders (MonoBind b _ _) 
- = collectMonoBinders b
-collectHsBinders (ThenBinds b1 b2)
- = collectHsBinders b1 ++ collectHsBinders b2
+collectHsBinders :: HsBinds name -> [name]
+collectHsBinders EmptyBinds 	   = []
+collectHsBinders (IPBinds _ _)	   = []		-- Implicit parameters don't create
+						-- ordinary bindings
+collectHsBinders (MonoBind b _ _)  = collectMonoBinders b
+collectHsBinders (ThenBinds b1 b2) = collectHsBinders b1 ++ collectHsBinders b2
 
-collectLocatedMonoBinders :: MonoBinds name (InPat name) -> [(name,SrcLoc)]
+collectLocatedMonoBinders :: MonoBinds name -> [(name,SrcLoc)]
 collectLocatedMonoBinders binds
   = go binds []
   where
@@ -140,7 +141,7 @@ collectLocatedMonoBinders binds
     go (FunMonoBind f _ _ loc) acc = (f,loc) : acc
     go (AndMonoBinds bs1 bs2)  acc = go bs1 (go bs2 acc)
 
-collectMonoBinders :: MonoBinds name (InPat name) -> [name]
+collectMonoBinders :: MonoBinds name -> [name]
 collectMonoBinders binds
   = go binds []
   where
@@ -149,3 +150,52 @@ collectMonoBinders binds
     go (FunMonoBind f _ _ loc) acc = f : acc
     go (AndMonoBinds bs1 bs2)  acc = go bs1 (go bs2 acc)
 \end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Getting patterns out of bindings}
+%*									*
+%************************************************************************
+
+Get all the pattern type signatures out of a bunch of bindings
+
+\begin{code}
+collectSigTysFromHsBinds :: HsBinds name -> [HsType name]
+collectSigTysFromHsBinds EmptyBinds        = [] 
+collectSigTysFromHsBinds (IPBinds _ _)     = [] 
+collectSigTysFromHsBinds (MonoBind b _ _)  = collectSigTysFromMonoBinds b
+collectSigTysFromHsBinds (ThenBinds b1 b2) = collectSigTysFromHsBinds b1 ++
+					     collectSigTysFromHsBinds b2
+ 
+
+collectSigTysFromMonoBinds :: MonoBinds name -> [HsType name]
+collectSigTysFromMonoBinds bind
+  = go bind []
+  where
+    go EmptyMonoBinds           acc = acc
+    go (PatMonoBind pat _ loc)  acc = collectSigTysFromPat pat ++ acc
+    go (FunMonoBind f _ ms loc) acc = go_matches ms acc
+    go (AndMonoBinds bs1 bs2)   acc = go bs1 (go bs2 acc)
+
+	-- A binding like    x :: a = f y
+	-- is parsed as FunMonoBind, but for this purpose we 	
+	-- want to treat it as a pattern binding
+    go_matches []				 acc = acc
+    go_matches (Match [] (Just sig) _ : matches) acc = sig : go_matches matches acc
+    go_matches (match		      : matches) acc = go_matches matches acc
+\end{code}
+
+\begin{code}
+collectStmtsBinders :: [Stmt id] -> [id]
+collectStmtsBinders = concatMap collectStmtBinders
+
+collectStmtBinders :: Stmt id -> [id]
+  -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
+collectStmtBinders (BindStmt pat _ _) = collectPatBinders pat
+collectStmtBinders (LetStmt binds)    = collectHsBinders binds
+collectStmtBinders (ExprStmt _ _ _)   = []
+collectStmtBinders (ResultStmt _ _)   = []
+collectStmtBinders other              = panic "collectStmtBinders"
+\end{code}
+