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