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 import Ubiq{-uitous-}
  14
  15 -- friends:
  16 import HsLoop
  17
  18 import HsMatches        ( pprMatches, pprGRHSsAndBinds,
  19                           Match, GRHSsAndBinds
  20                         )
  21 import HsPat            ( collectPatBinders, InPat )
  22 import HsPragmas        ( GenPragmas, ClassOpPragmas )
  23 import HsTypes          ( PolyType )
  24
  25 --others:
  26 import Id               ( DictVar(..), Id(..), GenId )
  27 import Outputable
  28 import PprType          ( pprType )
  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 [pprNonOp 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 [pprNonOp 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", pprNonOp sty var])
 165                    4 (ppStr "#-}")
 166
 167     ppr sty (SpecSig var ty using _)
 168       = ppHang (ppCat [ppPStr SLIT("{-# SPECIALIZE"), pprNonOp 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"), pprNonOp sty var, ppPStr SLIT("#-}")]
 176
 177     ppr sty (MagicUnfoldingSig var str _)
 178       = ppCat [ppPStr SLIT("{-# MAGIC_UNFOLDING"), pprNonOp 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                     [Match tyvar uvar id pat]   -- must have at least one Match
 241                     SrcLoc
 242   | VarMonoBind     id                  -- TRANSLATION
 243                     (HsExpr tyvar uvar id pat)
 244 \end{code}
 245
 246 \begin{code}
 247 nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool
 248
 249 nullMonoBinds EmptyMonoBinds         = True
 250 nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
 251 nullMonoBinds other_monobind         = False
 252 \end{code}
 253
 254 \begin{code}
 255 instance (NamedThing id, Outputable id, Outputable pat,
 256           Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
 257                 Outputable (MonoBinds tyvar uvar id pat) where
 258     ppr sty EmptyMonoBinds = ppNil
 259     ppr sty (AndMonoBinds binds1 binds2)
 260       = ppAbove (ppr sty binds1) (ppr sty binds2)
 261
 262     ppr sty (PatMonoBind pat grhss_n_binds locn)
 263       = ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)
 264
 265     ppr sty (FunMonoBind fun matches locn)
 266       = pprMatches sty (False, pprNonOp sty fun) matches
 267
 268     ppr sty (VarMonoBind name expr)
 269       = ppHang (ppCat [pprNonOp sty name, ppEquals]) 4 (ppr sty expr)
 270 \end{code}
 271
 272 %************************************************************************
 273 %*                                                                      *
 274 \subsection{Collecting binders from @HsBinds@}
 275 %*                                                                      *
 276 %************************************************************************
 277
 278 Get all the binders in some @MonoBinds@, IN THE ORDER OF
 279 APPEARANCE; e.g., in:
 280 \begin{verbatim}
 281 ...
 282 where
 283   (x, y) = ...
 284   f i j  = ...
 285   [a, b] = ...
 286 \end{verbatim}
 287 it should return @[x, y, f, a, b]@ (remember, order important).
 288
 289 \begin{code}
 290 collectTopLevelBinders :: HsBinds tyvar uvar name (InPat name) -> [name]
 291 collectTopLevelBinders EmptyBinds     = []
 292 collectTopLevelBinders (SingleBind b) = collectBinders b
 293 collectTopLevelBinders (BindWith b _) = collectBinders b
 294 collectTopLevelBinders (ThenBinds b1 b2)
 295  = collectTopLevelBinders b1 ++ collectTopLevelBinders b2
 296
 297 collectBinders :: Bind tyvar uvar name (InPat name) -> [name]
 298 collectBinders EmptyBind              = []
 299 collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds
 300 collectBinders (RecBind monobinds)    = collectMonoBinders monobinds
 301
 302 collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> [name]
 303 collectMonoBinders EmptyMonoBinds                    = []
 304 collectMonoBinders (PatMonoBind pat grhss_w_binds _) = collectPatBinders pat
 305 collectMonoBinders (FunMonoBind f matches _)         = [f]
 306 collectMonoBinders (VarMonoBind v expr)              = error "collectMonoBinders"
 307 collectMonoBinders (AndMonoBinds bs1 bs2)
 308  = collectMonoBinders bs1 ++ collectMonoBinders bs2
 309
 310 -- We'd like the binders -- and where they came from --
 311 -- so we can make new ones with equally-useful origin info.
 312
 313 collectMonoBindersAndLocs
 314         :: MonoBinds tyvar uvar name (InPat name) -> [(name, SrcLoc)]
 315
 316 collectMonoBindersAndLocs EmptyMonoBinds = []
 317
 318 collectMonoBindersAndLocs (AndMonoBinds bs1 bs2)
 319   = collectMonoBindersAndLocs bs1 ++ collectMonoBindersAndLocs bs2
 320
 321 collectMonoBindersAndLocs (PatMonoBind pat grhss_w_binds locn)
 322   = collectPatBinders pat `zip` repeat locn
 323
 324 collectMonoBindersAndLocs (FunMonoBind f matches locn) = [(f, locn)]
 325
 326 #ifdef DEBUG
 327 collectMonoBindersAndLocs (VarMonoBind v expr)
 328   = trace "collectMonoBindersAndLocs:VarMonoBind" []
 329         -- ToDo: this is dubious, i.e., wrong, but harmless?
 330 #endif
 331 \end{code}