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)]      -- (old, new) 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 \begin{code}
  84 nullBinds :: HsBinds tyvar uvar id pat -> Bool
  85
  86 nullBinds EmptyBinds            = True
  87 nullBinds (ThenBinds b1 b2)     = nullBinds b1 && nullBinds b2
  88 nullBinds (SingleBind b)        = nullBind b
  89 nullBinds (BindWith b _)        = nullBind b
  90 nullBinds (AbsBinds _ _ _ ds b) = null ds && nullBind b
  91 \end{code}
  92
  93 \begin{code}
  94 instance (Outputable pat, NamedThing id, Outputable id,
  95           Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
  96                 Outputable (HsBinds tyvar uvar id pat) where
  97
  98     ppr sty EmptyBinds = ppNil
  99     ppr sty (ThenBinds binds1 binds2)
 100      = ppAbove (ppr sty binds1) (ppr sty binds2)
 101     ppr sty (SingleBind bind) = ppr sty bind
 102     ppr sty (BindWith bind sigs)
 103      = ppAbove (if null sigs
 104                 then ppNil
 105                 else ppAboves (map (ppr sty) sigs))
 106                (ppr sty bind)
 107     ppr sty (AbsBinds tyvars dictvars local_pairs dict_binds val_binds)
 108      = ppAbove (ppSep [ppPStr SLIT("AbsBinds"),
 109                       ppBesides[ppLbrack, interpp'SP sty tyvars, ppRbrack],
 110                       ppBesides[ppLbrack, interpp'SP sty dictvars, ppRbrack],
 111                       ppBesides[ppLbrack, interpp'SP sty local_pairs, ppRbrack]])
 112             (ppNest 4 (ppAbove (ppAboves (map (ppr sty) dict_binds)) (ppr sty val_binds)))
 113 \end{code}
 114
 115 %************************************************************************
 116 %*                                                                      *
 117 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 118 %*                                                                      *
 119 %************************************************************************
 120
 121 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 122 ``specialise this function to these four types...'') in with type
 123 signatures.  Then all the machinery to move them into place, etc.,
 124 serves for both.
 125
 126 \begin{code}
 127 data Sig name
 128   = Sig         name            -- a bog-std type signature
 129                 (HsType name)
 130                 SrcLoc
 131
 132   | ClassOpSig  name            -- class-op sigs have different pragmas
 133                 (HsType name)
 134                 (ClassOpPragmas name)   -- only interface ones have pragmas
 135                 SrcLoc
 136
 137   | SpecSig     name            -- specialise a function or datatype ...
 138                 (HsType name) -- ... to these types
 139                 (Maybe name)    -- ... maybe using this as the code for it
 140                 SrcLoc
 141
 142   | InlineSig   name              -- INLINE f
 143                 SrcLoc
 144
 145   | DeforestSig name            -- Deforest using this function definition
 146                 SrcLoc
 147
 148   | MagicUnfoldingSig
 149                 name            -- Associate the "name"d function with
 150                 FAST_STRING     -- the compiler-builtin unfolding (known
 151                 SrcLoc          -- by the String name)
 152 \end{code}
 153
 154 \begin{code}
 155 instance (NamedThing name, Outputable name) => Outputable (Sig name) where
 156     ppr sty (Sig var ty _)
 157       = ppHang (ppCat [ppr sty var, ppPStr SLIT("::")])
 158              4 (ppr sty ty)
 159
 160     ppr sty (ClassOpSig var ty pragmas _)
 161       = ppHang (ppCat [ppr sty (getOccName var), ppPStr SLIT("::")])
 162              4 (ppHang (ppr sty ty)
 163                      4 (ifnotPprForUser sty (ppr sty pragmas)))
 164
 165     ppr sty (DeforestSig var _)
 166       = ppHang (ppCat [ppStr "{-# DEFOREST", pprNonSym sty var])
 167                    4 (ppStr "#-}")
 168
 169     ppr sty (SpecSig var ty using _)
 170       = ppHang (ppCat [ppPStr SLIT("{-# SPECIALIZE"), pprNonSym sty var, ppPStr SLIT("::")])
 171              4 (ppCat [ppr sty ty, pp_using using, ppPStr SLIT("#-}")])
 172       where
 173         pp_using Nothing   = ppNil
 174         pp_using (Just me) = ppCat [ppChar '=', ppr sty me]
 175
 176     ppr sty (InlineSig var _)
 177       = ppCat [ppPStr SLIT("{-# INLINE"), pprNonSym sty var, ppPStr SLIT("#-}")]
 178
 179     ppr sty (MagicUnfoldingSig var str _)
 180       = ppCat [ppPStr SLIT("{-# MAGIC_UNFOLDING"), pprNonSym sty var, ppPStr str, ppPStr SLIT("#-}")]
 181 \end{code}
 182
 183 %************************************************************************
 184 %*                                                                      *
 185 \subsection{Binding: @Bind@}
 186 %*                                                                      *
 187 %************************************************************************
 188
 189 \begin{code}
 190 data Bind tyvar uvar id pat             -- binders and bindees
 191   = EmptyBind   -- because it's convenient when parsing signatures
 192   | NonRecBind  (MonoBinds tyvar uvar id pat)
 193   | RecBind     (MonoBinds tyvar uvar id pat)
 194 \end{code}
 195
 196 \begin{code}
 197 nullBind :: Bind tyvar uvar id pat -> Bool
 198
 199 nullBind EmptyBind       = True
 200 nullBind (NonRecBind bs) = nullMonoBinds bs
 201 nullBind (RecBind bs)    = nullMonoBinds bs
 202 \end{code}
 203
 204 \begin{code}
 205 bindIsRecursive :: Bind tyvar uvar id pat -> Bool
 206
 207 bindIsRecursive EmptyBind       = False
 208 bindIsRecursive (NonRecBind _)  = False
 209 bindIsRecursive (RecBind _)     = True
 210 \end{code}
 211
 212 \begin{code}
 213 instance (NamedThing id, Outputable id, Outputable pat,
 214           Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
 215                 Outputable (Bind tyvar uvar id pat) where
 216     ppr sty EmptyBind = ppNil
 217     ppr sty (NonRecBind binds)
 218      = ppAbove (ifnotPprForUser sty (ppStr "{- nonrec -}"))
 219                (ppr sty binds)
 220     ppr sty (RecBind binds)
 221      = ppAbove (ifnotPprForUser sty (ppStr "{- rec -}"))
 222                (ppr sty binds)
 223 \end{code}
 224
 225 %************************************************************************
 226 %*                                                                      *
 227 \subsection{Bindings: @MonoBinds@}
 228 %*                                                                      *
 229 %************************************************************************
 230
 231 Global bindings (where clauses)
 232
 233 \begin{code}
 234 data MonoBinds tyvar uvar id pat
 235   = EmptyMonoBinds
 236   | AndMonoBinds    (MonoBinds tyvar uvar id pat)
 237                     (MonoBinds tyvar uvar id pat)
 238   | PatMonoBind     pat
 239                     (GRHSsAndBinds tyvar uvar id pat)
 240                     SrcLoc
 241   | FunMonoBind     id
 242                     Bool                        -- True => infix declaration
 243                     [Match tyvar uvar id pat]   -- must have at least one Match
 244                     SrcLoc
 245
 246   | VarMonoBind     id                  -- TRANSLATION
 247                     (HsExpr tyvar uvar id pat)
 248
 249   | CoreMonoBind    id                  -- TRANSLATION
 250                     CoreExpr            -- No zonking; this is a final CoreExpr with Ids and Types!
 251 \end{code}
 252
 253 \begin{code}
 254 nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool
 255
 256 nullMonoBinds EmptyMonoBinds         = True
 257 nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
 258 nullMonoBinds other_monobind         = False
 259 \end{code}
 260
 261 \begin{code}
 262 instance (NamedThing id, Outputable id, Outputable pat,
 263           Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
 264                 Outputable (MonoBinds tyvar uvar id pat) where
 265     ppr sty EmptyMonoBinds = ppNil
 266     ppr sty (AndMonoBinds binds1 binds2)
 267       = ppAbove (ppr sty binds1) (ppr sty binds2)
 268
 269     ppr sty (PatMonoBind pat grhss_n_binds locn)
 270       = ppHang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)
 271
 272     ppr sty (FunMonoBind fun inf matches locn)
 273       = pprMatches sty (False, ppr sty fun) matches
 274       -- ToDo: print infix if appropriate
 275
 276     ppr sty (VarMonoBind name expr)
 277       = ppHang (ppCat [ppr sty name, ppEquals]) 4 (ppr sty expr)
 278
 279     ppr sty (CoreMonoBind name expr)
 280       = ppHang (ppCat [ppr sty name, ppEquals]) 4 (ppr sty expr)
 281 \end{code}
 282
 283 %************************************************************************
 284 %*                                                                      *
 285 \subsection{Collecting binders from @HsBinds@}
 286 %*                                                                      *
 287 %************************************************************************
 288
 289 Get all the binders in some @MonoBinds@, IN THE ORDER OF
 290 APPEARANCE; e.g., in:
 291 \begin{verbatim}
 292 ...
 293 where
 294   (x, y) = ...
 295   f i j  = ...
 296   [a, b] = ...
 297 \end{verbatim}
 298 it should return @[x, y, f, a, b]@ (remember, order important).
 299
 300 \begin{code}
 301 collectTopBinders :: HsBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
 302 collectTopBinders EmptyBinds     = emptyBag
 303 collectTopBinders (SingleBind b) = collectBinders b
 304 collectTopBinders (BindWith b _) = collectBinders b
 305 collectTopBinders (ThenBinds b1 b2)
 306  = collectTopBinders b1 `unionBags` collectTopBinders b2
 307
 308 collectBinders :: Bind tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
 309 collectBinders EmptyBind              = emptyBag
 310 collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds
 311 collectBinders (RecBind monobinds)    = collectMonoBinders monobinds
 312
 313 collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
 314 collectMonoBinders EmptyMonoBinds                      = emptyBag
 315 collectMonoBinders (PatMonoBind pat grhss_w_binds loc) = listToBag (map (\v->(v,loc)) (collectPatBinders pat))
 316 collectMonoBinders (FunMonoBind f _ matches loc)       = unitBag (f,loc)
 317 collectMonoBinders (VarMonoBind v expr)                = error "collectMonoBinders"
 318 collectMonoBinders (CoreMonoBind v expr)               = error "collectMonoBinders"
 319 collectMonoBinders (AndMonoBinds bs1 bs2)
 320  = collectMonoBinders bs1 `unionBags` collectMonoBinders bs2
 321 \end{code}