ghc/compiler/hsSyn/HsBinds.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[HsBinds]{Abstract syntax: top-level bindings and signatures}
   5
   6 Datatype for: @HsBinds@, @Bind@, @Sig@, @MonoBinds@.
   7
   8 \begin{code}
   9 #include "HsVersions.h"
  10
  11 module HsBinds where
  12
  13 IMP_Ubiq()
  14
  15 -- friends:
  16 IMPORT_DELOOPER(HsLoop)
  17 import HsMatches        ( pprMatches, pprGRHSsAndBinds,
  18                           Match, GRHSsAndBinds )
  19 import HsPat            ( collectPatBinders, InPat )
  20 import HsPragmas        ( GenPragmas, ClassOpPragmas )
  21 import HsTypes          ( PolyType )
  22
  23 --others:
  24 import Id               ( DictVar(..), Id(..), GenId )
  25 import Name             ( pprNonSym )
  26 import Outputable       ( interpp'SP, ifnotPprForUser,
  27                           Outputable(..){-instance * (,)-}
  28                         )
  29 import Pretty
  30 import SrcLoc           ( SrcLoc{-instances-} )
  31 --import TyVar          ( GenTyVar{-instances-} )
  32 \end{code}
  33
  34 %************************************************************************
  35 %*                                                                      *
  36 \subsection{Bindings: @HsBinds@}
  37 %*                                                                      *
  38 %************************************************************************
  39
  40 The following syntax may produce new syntax which is not part of the input,
  41 and which is instead a translation of the input to the typechecker.
  42 Syntax translations are marked TRANSLATION in comments. New empty
  43 productions are useful in development but may not appear in the final
  44 grammar.
  45
  46 Collections of bindings, created by dependency analysis and translation:
  47
  48 \begin{code}
  49 data HsBinds tyvar uvar id pat          -- binders and bindees
  50   = EmptyBinds
  51
  52   | ThenBinds   (HsBinds tyvar uvar id pat)
  53                 (HsBinds tyvar uvar id pat)
  54
  55   | SingleBind  (Bind  tyvar uvar id pat)
  56
  57   | BindWith            -- Bind with a type signature.
  58                         -- These appear only on typechecker input
  59                         -- (PolyType [in Sigs] can't appear on output)
  60                 (Bind tyvar uvar id pat)
  61                 [Sig id]
  62
  63   | AbsBinds                    -- Binds abstraction; TRANSLATION
  64                 [tyvar]
  65                 [id]            -- Dicts
  66                 [(id, id)]      -- (old, new) pairs
  67                 [(id, HsExpr tyvar uvar id pat)]        -- local dictionaries
  68                 (Bind tyvar uvar id pat)                -- "the business end"
  69
  70         -- Creates bindings for *new* (polymorphic, overloaded) locals
  71         -- in terms of *old* (monomorphic, non-overloaded) ones.
  72         --
  73         -- See section 9 of static semantics paper for more details.
  74         -- (You can get a PhD for explaining the True Meaning
  75         --  of this last construct.)
  76 \end{code}
  77
  78 \begin{code}
  79 nullBinds :: HsBinds tyvar uvar id pat -> Bool
  80
  81 nullBinds EmptyBinds            = True
  82 nullBinds (ThenBinds b1 b2)     = nullBinds b1 && nullBinds b2
  83 nullBinds (SingleBind b)        = nullBind b
  84 nullBinds (BindWith b _)        = nullBind b
  85 nullBinds (AbsBinds _ _ _ ds b) = null ds && nullBind b
  86 \end{code}
  87
  88 \begin{code}
  89 instance (Outputable pat, NamedThing id, Outputable id,
  90           Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
  91                 Outputable (HsBinds tyvar uvar id pat) where
  92
  93     ppr sty EmptyBinds = ppNil
  94     ppr sty (ThenBinds binds1 binds2)
  95      = ppAbove (ppr sty binds1) (ppr sty binds2)
  96     ppr sty (SingleBind bind) = ppr sty bind
  97     ppr sty (BindWith bind sigs)
  98      = ppAbove (if null sigs
  99                 then ppNil
 100                 else ppAboves (map (ppr sty) sigs))
 101                (ppr sty bind)
 102     ppr sty (AbsBinds tyvars dictvars local_pairs dict_binds val_binds)
 103      = ppAbove (ppSep [ppPStr SLIT("AbsBinds"),
 104                       ppBesides[ppLbrack, interpp'SP sty tyvars, ppRbrack],
 105                       ppBesides[ppLbrack, interpp'SP sty dictvars, ppRbrack],
 106                       ppBesides[ppLbrack, interpp'SP sty local_pairs, ppRbrack]])
 107             (ppNest 4 (ppAbove (ppAboves (map (ppr sty) dict_binds)) (ppr sty val_binds)))
 108 \end{code}
 109
 110 %************************************************************************
 111 %*                                                                      *
 112 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 113 %*                                                                      *
 114 %************************************************************************
 115
 116 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 117 ``specialise this function to these four types...'') in with type
 118 signatures.  Then all the machinery to move them into place, etc.,
 119 serves for both.
 120
 121 \begin{code}
 122 data Sig name
 123   = Sig         name            -- a bog-std type signature
 124                 (PolyType name)
 125                 (GenPragmas name) -- only interface ones have pragmas
 126                 SrcLoc
 127
 128   | ClassOpSig  name            -- class-op sigs have different pragmas
 129                 (PolyType name)
 130                 (ClassOpPragmas name)   -- only interface ones have pragmas
 131                 SrcLoc
 132
 133   | SpecSig     name            -- specialise a function or datatype ...
 134                 (PolyType name) -- ... to these types
 135                 (Maybe name)    -- ... maybe using this as the code for it
 136                 SrcLoc
 137
 138   | InlineSig   name              -- INLINE f
 139                 SrcLoc
 140
 141   -- ToDo: strictly speaking, could omit based on -DOMIT_DEFORESTER
 142   | DeforestSig name            -- Deforest using this function definition
 143                 SrcLoc
 144
 145   | MagicUnfoldingSig
 146                 name            -- Associate the "name"d function with
 147                 FAST_STRING     -- the compiler-builtin unfolding (known
 148                 SrcLoc          -- by the String name)
 149 \end{code}
 150
 151 \begin{code}
 152 instance (NamedThing name, Outputable name) => Outputable (Sig name) where
 153     ppr sty (Sig var ty pragmas _)
 154       = ppHang (ppCat [pprNonSym sty var, ppPStr SLIT("::")])
 155              4 (ppHang (ppr sty ty)
 156                      4 (ifnotPprForUser sty (ppr sty pragmas)))
 157
 158     ppr sty (ClassOpSig var ty pragmas _)
 159       = ppHang (ppCat [pprNonSym sty var, ppPStr SLIT("::")])
 160              4 (ppHang (ppr sty ty)
 161                      4 (ifnotPprForUser sty (ppr sty pragmas)))
 162
 163     ppr sty (DeforestSig var _)
 164       = ppHang (ppCat [ppStr "{-# DEFOREST", pprNonSym sty var])
 165                    4 (ppStr "#-}")
 166
 167     ppr sty (SpecSig var ty using _)
 168       = ppHang (ppCat [ppPStr SLIT("{-# SPECIALIZE"), pprNonSym sty var, ppPStr SLIT("::")])
 169              4 (ppCat [ppr sty ty, pp_using using, ppPStr SLIT("#-}")])
 170       where
 171         pp_using Nothing   = ppNil
 172         pp_using (Just me) = ppCat [ppChar '=', ppr sty me]
 173
 174     ppr sty (InlineSig var _)
 175       = ppCat [ppPStr SLIT("{-# INLINE"), pprNonSym sty var, ppPStr SLIT("#-}")]
 176
 177     ppr sty (MagicUnfoldingSig var str _)
 178       = ppCat [ppPStr SLIT("{-# MAGIC_UNFOLDING"), pprNonSym sty var, ppPStr str, ppPStr SLIT("#-}")]
 179 \end{code}
 180
 181 %************************************************************************
 182 %*                                                                      *
 183 \subsection{Binding: @Bind@}
 184 %*                                                                      *
 185 %************************************************************************
 186
 187 \begin{code}
 188 data Bind tyvar uvar id pat             -- binders and bindees
 189   = EmptyBind   -- because it's convenient when parsing signatures
 190   | NonRecBind  (MonoBinds tyvar uvar id pat)
 191   | RecBind     (MonoBinds tyvar uvar id pat)
 192 \end{code}
 193
 194 \begin{code}
 195 nullBind :: Bind tyvar uvar id pat -> Bool
 196
 197 nullBind EmptyBind       = True
 198 nullBind (NonRecBind bs) = nullMonoBinds bs
 199 nullBind (RecBind bs)    = nullMonoBinds bs
 200 \end{code}
 201
 202 \begin{code}
 203 bindIsRecursive :: Bind tyvar uvar id pat -> Bool
 204
 205 bindIsRecursive EmptyBind       = False
 206 bindIsRecursive (NonRecBind _)  = False
 207 bindIsRecursive (RecBind _)     = True
 208 \end{code}
 209
 210 \begin{code}
 211 instance (NamedThing id, Outputable id, Outputable pat,
 212           Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
 213                 Outputable (Bind tyvar uvar id pat) where
 214     ppr sty EmptyBind = ppNil
 215     ppr sty (NonRecBind binds)
 216      = ppAbove (ifnotPprForUser sty (ppStr "{- nonrec -}"))
 217                (ppr sty binds)
 218     ppr sty (RecBind binds)
 219      = ppAbove (ifnotPprForUser sty (ppStr "{- rec -}"))
 220                (ppr sty binds)
 221 \end{code}
 222
 223 %************************************************************************
 224 %*                                                                      *
 225 \subsection{Bindings: @MonoBinds@}
 226 %*                                                                      *
 227 %************************************************************************
 228
 229 Global bindings (where clauses)
 230
 231 \begin{code}
 232 data MonoBinds tyvar uvar id pat
 233   = EmptyMonoBinds
 234   | AndMonoBinds    (MonoBinds tyvar uvar id pat)
 235                     (MonoBinds tyvar uvar id pat)
 236   | PatMonoBind     pat
 237                     (GRHSsAndBinds tyvar uvar id pat)
 238                     SrcLoc
 239   | FunMonoBind     id
 240                     Bool                        -- True => infix declaration
 241                     [Match tyvar uvar id pat]   -- must have at least one Match
 242                     SrcLoc
 243   | VarMonoBind     id                  -- TRANSLATION
 244                     (HsExpr tyvar uvar id pat)
 245 \end{code}
 246
 247 \begin{code}
 248 nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool
 249
 250 nullMonoBinds EmptyMonoBinds         = True
 251 nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
 252 nullMonoBinds other_monobind         = False
 253 \end{code}
 254
 255 \begin{code}
 256 instance (NamedThing id, Outputable id, Outputable pat,
 257           Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
 258                 Outputable (MonoBinds tyvar uvar id pat) where
 259     ppr sty EmptyMonoBinds = ppNil
 260     ppr sty (AndMonoBinds binds1 binds2)
 261       = ppAbove (ppr sty binds1) (ppr sty binds2)
 262
 263     ppr sty (PatMonoBind pat grhss_n_binds locn)
 264       = ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)
 265
 266     ppr sty (FunMonoBind fun inf matches locn)
 267       = pprMatches sty (False, pprNonSym sty fun) matches
 268       -- ToDo: print infix if appropriate
 269
 270     ppr sty (VarMonoBind name expr)
 271       = ppHang (ppCat [pprNonSym sty name, ppEquals]) 4 (ppr sty expr)
 272 \end{code}
 273
 274 %************************************************************************
 275 %*                                                                      *
 276 \subsection{Collecting binders from @HsBinds@}
 277 %*                                                                      *
 278 %************************************************************************
 279
 280 Get all the binders in some @MonoBinds@, IN THE ORDER OF
 281 APPEARANCE; e.g., in:
 282 \begin{verbatim}
 283 ...
 284 where
 285   (x, y) = ...
 286   f i j  = ...
 287   [a, b] = ...
 288 \end{verbatim}
 289 it should return @[x, y, f, a, b]@ (remember, order important).
 290
 291 \begin{code}
 292 collectTopLevelBinders :: HsBinds tyvar uvar name (InPat name) -> [name]
 293 collectTopLevelBinders EmptyBinds     = []
 294 collectTopLevelBinders (SingleBind b) = collectBinders b
 295 collectTopLevelBinders (BindWith b _) = collectBinders b
 296 collectTopLevelBinders (ThenBinds b1 b2)
 297  = collectTopLevelBinders b1 ++ collectTopLevelBinders b2
 298
 299 collectBinders :: Bind tyvar uvar name (InPat name) -> [name]
 300 collectBinders EmptyBind              = []
 301 collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds
 302 collectBinders (RecBind monobinds)    = collectMonoBinders monobinds
 303
 304 collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> [name]
 305 collectMonoBinders EmptyMonoBinds                    = []
 306 collectMonoBinders (PatMonoBind pat grhss_w_binds _) = collectPatBinders pat
 307 collectMonoBinders (FunMonoBind f _ matches _)       = [f]
 308 collectMonoBinders (VarMonoBind v expr)              = error "collectMonoBinders"
 309 collectMonoBinders (AndMonoBinds bs1 bs2)
 310  = collectMonoBinders bs1 ++ collectMonoBinders bs2
 311
 312 -- We'd like the binders -- and where they came from --
 313 -- so we can make new ones with equally-useful origin info.
 314
 315 collectMonoBindersAndLocs
 316         :: MonoBinds tyvar uvar name (InPat name) -> [(name, SrcLoc)]
 317
 318 collectMonoBindersAndLocs EmptyMonoBinds = []
 319
 320 collectMonoBindersAndLocs (AndMonoBinds bs1 bs2)
 321   = collectMonoBindersAndLocs bs1 ++ collectMonoBindersAndLocs bs2
 322
 323 collectMonoBindersAndLocs (PatMonoBind pat grhss_w_binds locn)
 324   = collectPatBinders pat `zip` repeat locn
 325
 326 collectMonoBindersAndLocs (FunMonoBind f _ matches locn) = [(f, locn)]
 327
 328 #ifdef DEBUG
 329 collectMonoBindersAndLocs (VarMonoBind v expr)
 330   = trace "collectMonoBindersAndLocs:VarMonoBind" []
 331         -- ToDo: this is dubious, i.e., wrong, but harmless?
 332 #endif
 333 \end{code}