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             ( getOccName, OccName, NamedThing(..) )
  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   | MonoBind    (MonoBinds tyvar uvar id pat)
  61                 [Sig id]                -- Empty on typechecker output
  62                 RecFlag
  63
  64 type RecFlag = Bool
  65 recursive    = True
  66 nonRecursive = False
  67 \end{code}
  68
  69 \begin{code}
  70 nullBinds :: HsBinds tyvar uvar id pat -> Bool
  71
  72 nullBinds EmptyBinds            = True
  73 nullBinds (ThenBinds b1 b2)     = nullBinds b1 && nullBinds b2
  74 nullBinds (MonoBind b _ _)      = nullMonoBinds b
  75 \end{code}
  76
  77 \begin{code}
  78 instance (Outputable pat, NamedThing id, Outputable id,
  79           Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
  80                 Outputable (HsBinds tyvar uvar id pat) where
  81
  82     ppr sty EmptyBinds = empty
  83     ppr sty (ThenBinds binds1 binds2)
  84      = ($$) (ppr sty binds1) (ppr sty binds2)
  85     ppr sty (MonoBind bind sigs is_rec)
  86      = vcat [
  87         ifnotPprForUser sty (ptext rec_str),
  88         if null sigs
  89           then empty
  90           else vcat (map (ppr sty) sigs),
  91         ppr sty bind
  92        ]
  93      where
  94        rec_str | is_rec    = SLIT("{- rec -}")
  95                | otherwise = SLIT("{- nonrec -}")
  96 \end{code}
  97
  98 %************************************************************************
  99 %*                                                                      *
 100 \subsection{Bindings: @MonoBinds@}
 101 %*                                                                      *
 102 %************************************************************************
 103
 104 Global bindings (where clauses)
 105
 106 \begin{code}
 107 data MonoBinds tyvar uvar id pat
 108   = EmptyMonoBinds
 109
 110   | AndMonoBinds    (MonoBinds tyvar uvar id pat)
 111                     (MonoBinds tyvar uvar id pat)
 112
 113   | PatMonoBind     pat
 114                     (GRHSsAndBinds tyvar uvar id pat)
 115                     SrcLoc
 116
 117   | FunMonoBind     id
 118                     Bool                        -- True => infix declaration
 119                     [Match tyvar uvar id pat]   -- must have at least one Match
 120                     SrcLoc
 121
 122   | VarMonoBind     id                  -- TRANSLATION
 123                     (HsExpr tyvar uvar id pat)
 124
 125   | CoreMonoBind    id                  -- TRANSLATION
 126                     CoreExpr            -- No zonking; this is a final CoreExpr with Ids and Types!
 127
 128   | AbsBinds                    -- Binds abstraction; TRANSLATION
 129                 [tyvar]                   -- Type variables
 130                 [id]                      -- Dicts
 131                 [([tyvar], id, id)]       -- (type variables, polymorphic, momonmorphic) triples
 132                 (MonoBinds tyvar uvar id pat)    -- The "business end"
 133
 134         -- Creates bindings for *new* (polymorphic, overloaded) locals
 135         -- in terms of *old* (monomorphic, non-overloaded) ones.
 136         --
 137         -- See section 9 of static semantics paper for more details.
 138         -- (You can get a PhD for explaining the True Meaning
 139         --  of this last construct.)
 140 \end{code}
 141
 142 What AbsBinds means
 143 ~~~~~~~~~~~~~~~~~~~
 144          AbsBinds tvs
 145                   [d1,d2]
 146                   [(tvs1, f1p, f1m),
 147                    (tvs2, f2p, f2m)]
 148                   BIND
 149 means
 150
 151         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
 152                                       in fm
 153
 154         gp = ...same again, with gm instead of fm
 155
 156 This is a pretty bad translation, because it duplicates all the bindings.
 157 So the desugarer tries to do a better job:
 158
 159         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
 160                                         (fm,gm) -> fm
 161         ..ditto for gp..
 162
 163         p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
 164                                       in (fm,gm)
 165
 166 \begin{code}
 167 nullMonoBinds :: MonoBinds tyvar uvar id pat -> Bool
 168
 169 nullMonoBinds EmptyMonoBinds         = True
 170 nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
 171 nullMonoBinds other_monobind         = False
 172
 173 andMonoBinds :: [MonoBinds tyvar uvar id pat] -> MonoBinds tyvar uvar id pat
 174 andMonoBinds binds = foldr AndMonoBinds EmptyMonoBinds binds
 175 \end{code}
 176
 177 \begin{code}
 178 instance (NamedThing id, Outputable id, Outputable pat,
 179           Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) =>
 180                 Outputable (MonoBinds tyvar uvar id pat) where
 181     ppr sty EmptyMonoBinds = empty
 182     ppr sty (AndMonoBinds binds1 binds2)
 183       = ($$) (ppr sty binds1) (ppr sty binds2)
 184
 185     ppr sty (PatMonoBind pat grhss_n_binds locn)
 186       = hang (ppr sty pat) 4 (pprGRHSsAndBinds sty False grhss_n_binds)
 187
 188     ppr sty (FunMonoBind fun inf matches locn)
 189       = pprMatches sty (False, ppr sty fun) matches
 190       -- ToDo: print infix if appropriate
 191
 192     ppr sty (VarMonoBind name expr)
 193       = hang (hsep [ppr sty name, equals]) 4 (ppr sty expr)
 194
 195     ppr sty (CoreMonoBind name expr)
 196       = hang (hsep [ppr sty name, equals]) 4 (ppr sty expr)
 197
 198     ppr sty (AbsBinds tyvars dictvars exports val_binds)
 199      = ($$) (sep [ptext SLIT("AbsBinds"),
 200                       brackets (interpp'SP sty tyvars),
 201                       brackets (interpp'SP sty dictvars),
 202                       brackets (interpp'SP sty exports)])
 203                (nest 4 (ppr sty val_binds))
 204 \end{code}
 205
 206 %************************************************************************
 207 %*                                                                      *
 208 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 209 %*                                                                      *
 210 %************************************************************************
 211
 212 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 213 ``specialise this function to these four types...'') in with type
 214 signatures.  Then all the machinery to move them into place, etc.,
 215 serves for both.
 216
 217 \begin{code}
 218 data Sig name
 219   = Sig         name            -- a bog-std type signature
 220                 (HsType name)
 221                 SrcLoc
 222
 223   | ClassOpSig  name                    -- Selector name
 224                 name                    -- Default-method name
 225                 (HsType name)
 226                 SrcLoc
 227
 228   | SpecSig     name            -- specialise a function or datatype ...
 229                 (HsType name) -- ... to these types
 230                 (Maybe name)    -- ... maybe using this as the code for it
 231                 SrcLoc
 232
 233   | InlineSig   name              -- INLINE f
 234                 SrcLoc
 235
 236   | DeforestSig name            -- Deforest using this function definition
 237                 SrcLoc
 238
 239   | MagicUnfoldingSig
 240                 name            -- Associate the "name"d function with
 241                 FAST_STRING     -- the compiler-builtin unfolding (known
 242                 SrcLoc          -- by the String name)
 243 \end{code}
 244
 245 \begin{code}
 246 instance (NamedThing name, Outputable name) => Outputable (Sig name) where
 247     ppr sty (Sig var ty _)
 248       = hang (hsep [ppr sty var, ptext SLIT("::")])
 249              4 (ppr sty ty)
 250
 251     ppr sty (ClassOpSig var _ ty _)
 252       = hang (hsep [ppr sty (getOccName var), ptext SLIT("::")])
 253              4 (ppr sty ty)
 254
 255     ppr sty (DeforestSig var _)
 256       = hang (hsep [text "{-# DEFOREST", ppr sty var])
 257                    4 (text "#-")
 258
 259     ppr sty (SpecSig var ty using _)
 260       = hang (hsep [text "{-# SPECIALIZE", ppr sty var, ptext SLIT("::")])
 261              4 (hsep [ppr sty ty, pp_using using, text "#-}"])
 262
 263       where
 264         pp_using Nothing   = empty
 265         pp_using (Just me) = hsep [char '=', ppr sty me]
 266
 267     ppr sty (InlineSig var _)
 268
 269         = hsep [text "{-# INLINE", ppr sty var, text "#-}"]
 270
 271     ppr sty (MagicUnfoldingSig var str _)
 272       = hsep [text "{-# MAGIC_UNFOLDING", ppr sty var, ptext str, text "#-}"]
 273 \end{code}
 274
 275 %************************************************************************
 276 %*                                                                      *
 277 \subsection{Collecting binders from @HsBinds@}
 278 %*                                                                      *
 279 %************************************************************************
 280
 281 Get all the binders in some @MonoBinds@, IN THE ORDER OF
 282 APPEARANCE; e.g., in:
 283 \begin{verbatim}
 284 ...
 285 where
 286   (x, y) = ...
 287   f i j  = ...
 288   [a, b] = ...
 289 \end{verbatim}
 290 it should return @[x, y, f, a, b]@ (remember, order important).
 291
 292 \begin{code}
 293 collectTopBinders :: HsBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
 294 collectTopBinders EmptyBinds     = emptyBag
 295 collectTopBinders (MonoBind b _ _) = collectMonoBinders b
 296 collectTopBinders (ThenBinds b1 b2)
 297  = collectTopBinders b1 `unionBags` collectTopBinders b2
 298
 299 collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
 300 collectMonoBinders EmptyMonoBinds                      = emptyBag
 301 collectMonoBinders (PatMonoBind pat grhss_w_binds loc) = listToBag (map (\v->(v,loc)) (collectPatBinders pat))
 302 collectMonoBinders (FunMonoBind f _ matches loc)       = unitBag (f,loc)
 303 collectMonoBinders (VarMonoBind v expr)                = error "collectMonoBinders"
 304 collectMonoBinders (CoreMonoBind v expr)               = error "collectMonoBinders"
 305 collectMonoBinders (AndMonoBinds bs1 bs2)
 306  = collectMonoBinders bs1 `unionBags` collectMonoBinders bs2
 307 \end{code}