[project @ 2003-12-10 14:15:16 by simonmar]
[ghc-hetmet.git] / ghc / compiler / hsSyn / HsSyn.lhs
index f0f7c94..7255d1b 100644 (file)
@@ -9,22 +9,21 @@ therefore, is almost nothing but re-exporting.
 
 \begin{code}
 module HsSyn (
-
-       -- NB: don't reexport HsCore or HsPragmas;
-       -- this module tells about "real Haskell"
-
-       module HsSyn,
        module HsBinds,
        module HsDecls,
        module HsExpr,
        module HsImpExp,
        module HsLit,
-       module HsMatches,
        module HsPat,
        module HsTypes,
+       module HsUtils,
        Fixity, NewOrData, 
 
-       collectTopBinders, collectMonoBinders, collectLocatedMonoBinders
+       HsModule(..), HsExtCore(..),
+       collectStmtsBinders, collectStmtBinders, collectLStmtBinders,
+       collectGroupBinders, collectHsBindLocatedBinders,
+       collectHsBindBinders,
+       collectSigTysFromHsBind, collectSigTysFromHsBinds
      ) where
 
 #include "HsVersions.h"
@@ -35,50 +34,59 @@ import HsBinds
 import HsExpr
 import HsImpExp
 import HsLit
-import HsMatches
 import HsPat
 import HsTypes
-import HsCore
-import BasicTypes      ( Fixity, Version, NewOrData )
+import HscTypes                ( DeprecTxt )
+import BasicTypes      ( Fixity, NewOrData )
+import HsUtils
 
 -- others:
+import IfaceSyn                ( IfaceBinding )
 import Outputable
-import SrcLoc          ( SrcLoc )
-import Bag
-import Module          ( ModuleName, pprModuleName )
+import SrcLoc          ( Located(..), unLoc, noLoc )
+import Module          ( Module )
+import Bag             ( Bag, foldrBag )
 \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
-       (Maybe Version)         -- source interface version number
-       (Maybe [IE name])       -- export list; Nothing => export everything
-                               -- Just [] => export *nothing* (???)
+       (Maybe (Located Module))-- Nothing => "module X where" is omitted
+                               --      (in which case the next field is Nothing too)
+       (Maybe [LIE name])      -- Export list; Nothing => export list omitted, so export everything
+                               -- Just [] => export *nothing*
                                -- Just [...] => as you would expect...
-       [ImportDecl name]       -- We snaffle interesting stuff out of the
+       [LImportDecl name]      -- We snaffle interesting stuff out of the
                                -- 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
+       [LHsDecl name]  -- Type, class, value, and interface signature decls
        (Maybe DeprecTxt)       -- reason/explanation for deprecation of this module
-       SrcLoc
+
+data HsExtCore name    -- Read from Foo.hcr
+  = HsExtCore
+       Module
+       [TyClDecl name] -- Type declarations only; just as in Haskell source,
+                       -- so that we can infer kinds etc
+       [IfaceBinding]  -- And the bindings
 \end{code}
 
 \begin{code}
-instance (Outputable name, Outputable pat)
-       => Outputable (HsModule name pat) where
+instance (OutputableBndr name)
+       => Outputable (HsModule name) where
 
-    ppr (HsModule name iface_version exports imports
-                     decls deprec src_loc)
+    ppr (HsModule Nothing _ imports decls _)
+      = pp_nonnull imports $$ pp_nonnull decls
+
+    ppr (HsModule (Just name) exports imports decls deprec)
       = vcat [
            case exports of
              Nothing -> pp_header (ptext SLIT("where"))
              Just es -> vcat [
-                           pp_header lparen,
-                           nest 8 (fsep (punctuate comma (map ppr es))),
-                           nest 4 (ptext SLIT(") where"))
+                          pp_header lparen,
+                          nest 8 (fsep (punctuate comma (map ppr es))),
+                          nest 4 (ptext SLIT(") where"))
                          ],
            pp_nonnull imports,
            pp_nonnull decls
@@ -88,10 +96,10 @@ instance (Outputable name, Outputable pat)
            Nothing -> pp_modname <+> rest
            Just d -> vcat [ pp_modname, ppr d, rest ]
 
-       pp_modname = ptext SLIT("module") <+> pprModuleName name
+       pp_modname = ptext SLIT("module") <+> ppr name
 
-       pp_nonnull [] = empty
-       pp_nonnull xs = vcat (map ppr xs)
+pp_nonnull [] = empty
+pp_nonnull xs = vcat (map ppr xs)
 \end{code}
 
 
@@ -115,26 +123,72 @@ where
 it should return @[x, y, f, a, b]@ (remember, order important).
 
 \begin{code}
-collectTopBinders :: HsBinds name (InPat name) -> Bag (name,SrcLoc)
-collectTopBinders EmptyBinds        = emptyBag
-collectTopBinders (MonoBind b _ _)  = listToBag (collectLocatedMonoBinders b)
-collectTopBinders (ThenBinds b1 b2) = collectTopBinders b1 `unionBags` collectTopBinders b2
-
-collectLocatedMonoBinders :: MonoBinds name (InPat name) -> [(name,SrcLoc)]
-collectLocatedMonoBinders binds
-  = go binds []
-  where
-    go EmptyMonoBinds         acc = acc
-    go (PatMonoBind pat _ loc) acc = map (\v->(v,loc)) (collectPatBinders pat) ++ acc
-    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 binds
-  = go binds []
+collectGroupBinders :: [HsBindGroup name] -> [Located name]
+collectGroupBinders groups = foldr collect_group [] groups
+       where
+         collect_group (HsBindGroup bag sigs is_rec) acc
+               = foldrBag (collectAcc . unLoc) acc bag
+         collect_group (HsIPBinds _) acc = acc
+
+
+collectAcc :: HsBind name -> [Located name] -> [Located name]
+collectAcc (PatBind pat _) acc = collectLocatedPatBinders pat ++ acc
+collectAcc (FunBind f _ _) acc = f : acc
+collectAcc (VarBind f _) acc  = noLoc f : acc
+collectAcc (AbsBinds _ _ dbinds _ binds) acc
+  = [noLoc dp | (_,dp,_) <- dbinds] ++ acc
+       -- ++ foldr collectAcc acc binds
+       -- I don't think we want the binders from the nested binds
+       -- The only time we collect binders from a typechecked 
+       -- binding (hence see AbsBinds) is in zonking in TcHsSyn
+
+collectHsBindBinders :: Bag (LHsBind name) -> [name]
+collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
+
+collectHsBindLocatedBinders :: Bag (LHsBind name) -> [Located name]
+collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
+\end{code}
+
+
+%************************************************************************
+%*                                                                     *
+\subsection{Getting patterns out of bindings}
+%*                                                                     *
+%************************************************************************
+
+Get all the pattern type signatures out of a bunch of bindings
+
+\begin{code}
+collectSigTysFromHsBinds :: [LHsBind name] -> [LHsType name]
+collectSigTysFromHsBinds binds = concat (map collectSigTysFromHsBind binds)
+
+collectSigTysFromHsBind :: LHsBind name -> [LHsType name]
+collectSigTysFromHsBind bind
+  = go (unLoc bind)
   where
-    go EmptyMonoBinds         acc = acc
-    go (PatMonoBind pat _ loc) acc = collectPatBinders pat ++ acc
-    go (FunMonoBind f _ _ loc) acc = f : acc
-    go (AndMonoBinds bs1 bs2)  acc = go bs1 (go bs2 acc)
+    go (PatBind pat _)  = collectSigTysFromPat pat
+    go (FunBind f _ ms) = go_matches (map unLoc ms)
+
+       -- 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 []                               = []
+    go_matches (Match [] (Just sig) _ : matches) = sig : go_matches matches
+    go_matches (match                : matches) = go_matches matches
+\end{code}
+
+\begin{code}
+collectStmtsBinders :: [LStmt id] -> [Located id]
+collectStmtsBinders = concatMap collectLStmtBinders
+
+collectLStmtBinders = collectStmtBinders . unLoc
+
+collectStmtBinders :: Stmt id -> [Located id]
+  -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
+collectStmtBinders (BindStmt pat _)   = collectLocatedPatBinders pat
+collectStmtBinders (LetStmt binds)    = collectGroupBinders binds
+collectStmtBinders (ExprStmt _ _)     = []
+collectStmtBinders (ResultStmt _)     = []
+collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss
+collectStmtBinders other              = panic "collectStmtBinders"
 \end{code}