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