+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[HsBinds]{Abstract syntax: top-level bindings and signatures}
-
-Datatype for: @Binds@, @Bind@, @Sig@, @MonoBinds@.
-
-\begin{code}
-#include "HsVersions.h"
-
-module HsBinds where
-
-import AbsUniType ( pprUniType, TyVar, UniType
- IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
- )
-import HsExpr ( Expr )
-import HsMatches ( pprMatches, pprGRHSsAndBinds, Match, GRHSsAndBinds )
-import HsPat ( ProtoNamePat(..), RenamedPat(..),
- TypecheckedPat, InPat
- IF_ATTACK_PRAGMAS(COMMA typeOfPat)
- )
-import HsPragmas ( GenPragmas, ClassOpPragmas )
-import HsTypes ( PolyType )
-import Id ( Id, DictVar(..) )
-import IdInfo ( UnfoldingGuidance )
-import Inst ( Inst )
-import Name ( Name )
-import Outputable
-import Pretty
-import ProtoName ( ProtoName(..) ) -- .. for pragmas only
-import SrcLoc ( SrcLoc )
-import Unique ( Unique )
-import Util
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSyn-Binds]{Bindings: @Binds@}
-%* *
-%************************************************************************
-
-The following syntax may produce new syntax which is not part of the input,
-and which is instead a translation of the input to the typechecker.
-Syntax translations are marked TRANSLATION in comments. New empty
-productions are useful in development but may not appear in the final
-grammar.
-
-Collections of bindings, created by dependency analysis and translation:
-
-\begin{code}
-data Binds bdee pat -- binders and bindees
- = EmptyBinds
-
- | ThenBinds (Binds bdee pat)
- (Binds bdee pat)
-
- | SingleBind (Bind bdee pat)
-
- | BindWith -- Bind with a type signature.
- -- These appear only on typechecker input
- -- (PolyType [in Sigs] can't appear on output)
- (Bind bdee pat) -- really ProtoNameBind, but...
- -- (see "really" comment below)
- [Sig bdee]
-
- | AbsBinds -- Binds abstraction; TRANSLATION
- [TyVar]
- [DictVar]
- [(Id, Id)] -- (old, new) pairs
- [(Inst, Expr bdee pat)] -- local dictionaries
- (Bind bdee pat) -- "the business end"
-
- -- Creates bindings for *new* (polymorphic, overloaded) locals
- -- in terms of *old* (monomorphic, non-overloaded) ones.
- --
- -- See section 9 of static semantics paper for more details.
- -- (You can get a PhD for explaining the True Meaning
- -- of this last construct.)
-\end{code}
-
-The corresponding unparameterised synonyms:
-
-\begin{code}
-type ProtoNameBinds = Binds ProtoName ProtoNamePat
-type RenamedBinds = Binds Name RenamedPat
-type TypecheckedBinds = Binds Id TypecheckedPat
-\end{code}
-
-\begin{code}
-nullBinds :: Binds bdee 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)
-\end{code}
-
-ToDo: make this recursiveness checking also require that
-there be something there, i.e., not null ?
-\begin{code}
-{- UNUSED:
-bindsAreRecursive :: TypecheckedBinds -> Bool
-
-bindsAreRecursive EmptyBinds = False
-bindsAreRecursive (ThenBinds b1 b2)
- = (bindsAreRecursive b1) || (bindsAreRecursive b2)
-bindsAreRecursive (SingleBind b) = bindIsRecursive b
-bindsAreRecursive (BindWith b _) = bindIsRecursive b
-bindsAreRecursive (AbsBinds _ _ _ ds b)
- = (bindsAreRecursive d) || (bindIsRecursive b)
--}
-\end{code}
-
-\begin{code}
-instance (NamedThing bdee, Outputable bdee,
- NamedThing pat, Outputable pat) =>
- Outputable (Binds bdee 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 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)))
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSyn-Sig]{@Sig@: type signatures and value-modifying user pragmas}
-%* *
-%************************************************************************
-
-It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
-``specialise this function to these four types...'') in with type
-signatures. Then all the machinery to move them into place, etc.,
-serves for both.
-
-\begin{code}
-data Sig name
- = Sig name -- a bog-std type signature
- (PolyType name)
- (GenPragmas name) -- only interface ones have pragmas
- SrcLoc
-
- | ClassOpSig name -- class-op sigs have different pragmas
- (PolyType name)
- (ClassOpPragmas name) -- only interface ones have pragmas
- SrcLoc
-
- | SpecSig name -- specialise a function or datatype ...
- (PolyType name) -- ... to these types
- (Maybe name) -- ... maybe using this as the code for it
- SrcLoc
-
- | InlineSig name -- INLINE f [howto]
- UnfoldingGuidance -- "howto": how gung-ho we are about inlining
- SrcLoc
-
- -- ToDo: strictly speaking, could omit based on -DOMIT_DEFORESTER
- | 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)
-
-type ProtoNameSig = Sig ProtoName
-type RenamedSig = Sig Name
-
-type ProtoNameClassOpSig = Sig ProtoName
-type RenamedClassOpSig = Sig Name
-\end{code}
-
-\begin{code}
-instance (Outputable name) => Outputable (Sig name) where
- ppr sty (Sig var ty pragmas _)
- = ppHang (ppCat [ppr sty var, ppPStr SLIT("::")])
- 4 (ppAbove (ppr sty ty)
- (ifnotPprForUser sty (ppr sty pragmas)))
-
- ppr sty (ClassOpSig var ty pragmas _)
- = ppHang (ppCat [ppr sty var, ppPStr SLIT("::")])
- 4 (ppAbove (ppr sty ty)
- (ifnotPprForUser sty (ppr sty pragmas)))
-
- ppr sty (DeforestSig var _)
- = ppHang (ppCat [ppStr "{-# DEFOREST", ppr sty var])
- 4 (ppStr "#-}")
-
- ppr sty (SpecSig var ty using _)
- = ppHang (ppCat [ppPStr SLIT("{-# SPECIALIZE"), ppr 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]
-
- ppr sty (InlineSig var _ _)
- = ppHang (ppCat [ppPStr SLIT("{-# INLINE"), ppr sty var])
- 4 (ppCat [ppPStr SLIT("<enthusiasm not done yet>"), ppPStr SLIT("#-}")])
-
- ppr sty (MagicUnfoldingSig var str _)
- = ppCat [ppPStr SLIT("{-# MAGIC_UNFOLDING"), ppr sty var, ppPStr str, ppPStr SLIT("#-}")]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[AbsSyn-Bind]{Binding: @Bind@}
-%* *
-%************************************************************************
-
-\begin{code}
-data Bind bdee pat -- binders and bindees
- = EmptyBind -- because it's convenient when parsing signatures
- | NonRecBind (MonoBinds bdee pat)
- | RecBind (MonoBinds bdee pat)
-\end{code}
-
-The corresponding unparameterised synonyms:
-
-\begin{code}
-type ProtoNameBind = Bind ProtoName ProtoNamePat
-type RenamedBind = Bind Name RenamedPat
-type TypecheckedBind = Bind Id TypecheckedPat
-\end{code}
-
-\begin{code}
-nullBind :: Bind bdee pat -> Bool
-nullBind EmptyBind = True
-nullBind (NonRecBind bs) = nullMonoBinds bs
-nullBind (RecBind bs) = nullMonoBinds bs
-\end{code}
-
-\begin{code}
-bindIsRecursive :: TypecheckedBind -> Bool
-bindIsRecursive EmptyBind = False
-bindIsRecursive (NonRecBind _) = False
-bindIsRecursive (RecBind _) = True
-\end{code}
-
-\begin{code}
-instance (NamedThing bdee, Outputable bdee,
- NamedThing pat, Outputable pat) =>
- Outputable (Bind bdee 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[AbsSyn-MonoBinds]{Bindings: @MonoBinds@}
-%* *
-%************************************************************************
-
-Global bindings (where clauses)
-
-\begin{code}
-data MonoBinds bdee pat -- binders and bindees
- = EmptyMonoBinds -- TRANSLATION
- | AndMonoBinds (MonoBinds bdee pat)
- (MonoBinds bdee pat)
- | PatMonoBind pat
- (GRHSsAndBinds bdee pat)
- SrcLoc
- | VarMonoBind Id -- TRANSLATION
- (Expr bdee pat)
- | FunMonoBind bdee
- [Match bdee pat] -- must have at least one Match
- SrcLoc
-\end{code}
-
-The corresponding unparameterised synonyms:
-\begin{code}
-type ProtoNameMonoBinds = MonoBinds ProtoName ProtoNamePat
-type RenamedMonoBinds = MonoBinds Name RenamedPat
-type TypecheckedMonoBinds = MonoBinds Id TypecheckedPat
-\end{code}
-
-\begin{code}
-nullMonoBinds :: MonoBinds bdee pat -> Bool
-nullMonoBinds EmptyMonoBinds = True
-nullMonoBinds (AndMonoBinds bs1 bs2) = (nullMonoBinds bs1) && (nullMonoBinds bs2)
-nullMonoBinds other_monobind = False
-\end{code}
-
-\begin{code}
-instance (NamedThing bdee, Outputable bdee,
- NamedThing pat, Outputable pat) =>
- Outputable (MonoBinds bdee 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)
- = ppAboves [
- ifPprShowAll sty (ppr sty locn),
- (if (hasType pat) then
- ppHang (ppCat [ppr sty pat, ppStr "::"]) 4 (pprUniType sty (getType pat))
- else
- ppNil
- ),
- (ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)) ]
-
- ppr sty (FunMonoBind fun matches locn)
- = ppAboves [
- ifPprShowAll sty (ppr sty locn),
- if (hasType fun) then
- ppHang (ppCat [pprNonOp sty fun, ppStr "::"]) 4
- (pprUniType sty (getType fun))
- else
- ppNil,
- pprMatches sty (False, pprNonOp sty fun) matches
- ]
-
- ppr sty (VarMonoBind name expr)
- = ppHang (ppCat [pprNonOp sty name, ppEquals]) 4 (ppr sty expr)
-\end{code}
projects / ghc-hetmet.git / blobdiff