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