%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section{Haskell abstract syntax definition}
therefore, is almost nothing but re-exporting.
\begin{code}
-#include "HsVersions.h"
-
module HsSyn (
- -- NB: don't reexport HsCore or HsPragmas;
+ -- NB: don't reexport HsCore
-- this module tells about "real Haskell"
- EXP_MODULE(HsSyn) ,
-#if (! defined(REALLY_HASKELL_1_3)) || PATRICK_FIXES_MODULE_DOTDOT_THING
- EXP_MODULE(HsBinds) ,
- EXP_MODULE(HsDecls) ,
- EXP_MODULE(HsExpr) ,
- EXP_MODULE(HsImpExp) ,
- EXP_MODULE(HsLit) ,
- EXP_MODULE(HsMatches) ,
- EXP_MODULE(HsPat) ,
- EXP_MODULE(HsTypes)
-#else
- ArithSeqInfo(..),
- BangType(..),
- Bind(..),
- ClassDecl(..),
- ConDecl(..),
- DefaultDecl(..),
- FixityDecl(..),
- GRHS(..),
- GRHSsAndBinds(..),
- HsBinds(..),
- HsExpr(..),
- HsLit(..),
- IE(..),
- ImportDecl(..),
- InPat(..),
- InstDecl(..),
- Match(..),
- MonoBinds(..),
- MonoType(..),
- OutPat(..),
- PolyType(..),
- Qualifier(..),
- Sig(..),
- SpecDataSig(..),
- SpecInstSig(..),
- Stmt(..),
- TyDecl(..),
- bindIsRecursive,
- cmpContext,
- cmpMonoType,
- cmpPolyType,
- collectBinders,
- collectMonoBinders,
- collectMonoBindersAndLocs,
- collectPatBinders,
- collectTopLevelBinders,
- extractCtxtTyNames,
- extractMonoTyNames,
- failureFreePat,
- irrefutablePat,
- irrefutablePats,
- isConPat,
- isLitPat,
- negLiteral,
- nullBind,
- nullBinds,
- nullMonoBinds,
- patsAreAllCons,
- patsAreAllLits,
- pp_condecls,
- pp_decl_head,
- pp_dotdot,
- pp_rbinds,
- pp_tydecl,
- pprContext,
- pprExpr,
- pprGRHS,
- pprGRHSsAndBinds,
- pprMatch,
- pprMatches,
- pprParendExpr,
- pprParendMonoType,
- pprParendPolyType,
- ppr_bang,
- print_it,
- SYN_IE(ClassAssertion),
- SYN_IE(Context),
- SYN_IE(HsRecordBinds)
-#endif
+ module HsSyn,
+ module HsBinds,
+ module HsDecls,
+ module HsExpr,
+ module HsImpExp,
+ module HsLit,
+ module HsPat,
+ module HsTypes,
+ Fixity, NewOrData,
+
+ collectHsBinders, collectHsOutBinders, collectLocatedHsBinders,
+ collectMonoBinders, collectLocatedMonoBinders,
+ collectSigTysFromMonoBinds,
+ hsModuleName, hsModuleImports
) where
-IMP_Ubiq()
+#include "HsVersions.h"
-- friends:
+import HsDecls
import HsBinds
-import HsDecls
import HsExpr
import HsImpExp
import HsLit
-import HsMatches
import HsPat
import HsTypes
-import HsPragmas ( ClassPragmas, ClassOpPragmas,
- DataPragmas, GenPragmas, InstancePragmas )
+import BasicTypes ( Fixity, Version, NewOrData )
+
-- others:
-import FiniteMap ( FiniteMap )
-import Outputable ( ifPprShowAll, ifnotPprForUser, interpp'SP, Outputable(..) )
-import Pretty
+import Name ( NamedThing )
+import Outputable
import SrcLoc ( SrcLoc )
-\end{code}
-
-@Fake@ is a placeholder type; for when tyvars and uvars aren't used.
-\begin{code}
-data Fake = Fake
-instance Eq Fake
-instance Outputable Fake
+import Module ( ModuleName )
\end{code}
All we actually declare here is the top-level structure for a module.
\begin{code}
-type Version = Int
-
-data HsModule tyvar uvar name pat
+data HsModule name pat
= HsModule
- Module -- module name
+ ModuleName -- module name
(Maybe Version) -- source interface version number
(Maybe [IE name]) -- export list; Nothing => export everything
-- Just [] => export *nothing* (???)
-- imported interfaces early on, adding that
-- info to TyDecls/etc; so this list is
-- often empty, downstream.
- [FixityDecl name]
- [TyDecl name]
- [SpecDataSig name] -- user pragmas that modify TyDecls
- [ClassDecl tyvar uvar name pat]
- [InstDecl tyvar uvar name pat]
- [SpecInstSig name] -- user pragmas that modify InstDecls
- [DefaultDecl name]
- (HsBinds tyvar uvar name pat) -- the main stuff, includes source sigs
- [Sig name] -- interface sigs
+ [HsDecl name pat] -- 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,
- Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
- => Outputable (HsModule tyvar uvar name pat) where
-
- ppr sty (HsModule name iface_version exports imports fixities
- typedecls typesigs classdecls instdecls instsigs
- defdecls binds sigs src_loc)
- = ppAboves [
- ifPprShowAll sty (ppr sty src_loc),
- ifnotPprForUser sty (pp_iface_version iface_version),
+instance (NamedThing name, Outputable name, Outputable pat)
+ => Outputable (HsModule name pat) where
+
+ ppr (HsModule name iface_version exports imports
+ decls deprec src_loc)
+ = vcat [
case exports of
- Nothing -> ppCat [ppPStr SLIT("module"), ppPStr name, ppPStr SLIT("where")]
- Just es -> ppAboves [
- ppCat [ppPStr SLIT("module"), ppPStr name, ppLparen],
- ppNest 8 (interpp'SP sty es),
- ppNest 4 (ppPStr SLIT(") where"))
+ 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_nonnull imports,
- pp_nonnull fixities,
- pp_nonnull typedecls,
- pp_nonnull typesigs,
- pp_nonnull classdecls,
- pp_nonnull instdecls,
- pp_nonnull instsigs,
- pp_nonnull defdecls,
- ppr sty binds,
- pp_nonnull sigs
+ pp_nonnull decls
]
where
- pp_nonnull [] = ppNil
- pp_nonnull xs = ppAboves (map (ppr sty) xs)
+ pp_header rest = case deprec of
+ Nothing -> pp_modname <+> rest
+ Just d -> vcat [ pp_modname, ppr d, rest ]
+
+ pp_modname = ptext SLIT("module") <+> ppr name
+
+ 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
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Collecting binders from @HsBinds@}
+%* *
+%************************************************************************
- pp_iface_version Nothing = ppNil
- pp_iface_version (Just n) = ppCat [ppStr "{-# INTERFACE", ppInt n, ppStr "#-}"]
+Get all the binders in some @MonoBinds@, IN THE ORDER OF APPEARANCE.
+
+These functions are here, rather than in HsBinds, to avoid a loop between HsPat and HsBinds.
+
+\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}
+collectLocatedHsBinders :: HsBinds name (InPat name) -> [(name,SrcLoc)]
+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
+
+-- corresponds to `collectHsBinders', but operates on renamed patterns
+--
+collectHsOutBinders :: HsBinds name (OutPat name) -> [name]
+collectHsOutBinders EmptyBinds = []
+collectHsOutBinders (MonoBind b _ _)
+ = collectMonoOutBinders b
+collectHsOutBinders (ThenBinds b1 b2)
+ = collectHsOutBinders b1 ++ collectHsOutBinders 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 []
+ 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)
+
+-- corresponds to `collectMonoBinders', but operates on renamed patterns
+--
+collectMonoOutBinders :: MonoBinds name (OutPat name) -> [name]
+collectMonoOutBinders binds
+ = go binds []
+ where
+ go EmptyMonoBinds acc = acc
+ go (PatMonoBind pat _ loc) acc = collectOutPatBinders pat ++ acc
+ 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}
+collectSigTysFromMonoBinds :: MonoBinds name (InPat 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}
+