ghc/compiler/hsSyn/HsBinds.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[HsBinds]{Abstract syntax: top-level bindings and signatures}
   5
   6 Datatype for: @HsBinds@, @Bind@, @Sig@, @MonoBinds@.
   7
   8 \begin{code}
   9 module HsBinds where
  10
  11 #include "HsVersions.h"
  12
  13 import {-# SOURCE #-} HsExpr    ( pprExpr, HsExpr )
  14 import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSs, GRHSs )
  15
  16 -- friends:
  17 import HsTypes          ( HsType )
  18 import HsImpExp         ( IE(..), ieName )
  19 import CoreSyn          ( CoreExpr )
  20 import PprCore          ()         -- Instances for Outputable
  21
  22 --others:
  23 import Id               ( Id )
  24 import NameSet          ( NameSet, nameSetToList )
  25 import BasicTypes       ( RecFlag(..), Fixity )
  26 import Outputable
  27 import Bag
  28 import SrcLoc           ( SrcLoc )
  29 import Var              ( TyVar )
  30 \end{code}
  31
  32 %************************************************************************
  33 %*                                                                      *
  34 \subsection{Bindings: @HsBinds@}
  35 %*                                                                      *
  36 %************************************************************************
  37
  38 The following syntax may produce new syntax which is not part of the input,
  39 and which is instead a translation of the input to the typechecker.
  40 Syntax translations are marked TRANSLATION in comments. New empty
  41 productions are useful in development but may not appear in the final
  42 grammar.
  43
  44 Collections of bindings, created by dependency analysis and translation:
  45
  46 \begin{code}
  47 data HsBinds id pat             -- binders and bindees
  48   = EmptyBinds
  49
  50   | ThenBinds   (HsBinds id pat)
  51                 (HsBinds id pat)
  52
  53   | MonoBind    (MonoBinds id pat)
  54                 [Sig id]                -- Empty on typechecker output
  55                 RecFlag
  56 \end{code}
  57
  58 \begin{code}
  59 nullBinds :: HsBinds id pat -> Bool
  60
  61 nullBinds EmptyBinds            = True
  62 nullBinds (ThenBinds b1 b2)     = nullBinds b1 && nullBinds b2
  63 nullBinds (MonoBind b _ _)      = nullMonoBinds b
  64
  65 mkMonoBind :: MonoBinds id pat -> [Sig id] -> RecFlag -> HsBinds id pat
  66 mkMonoBind EmptyMonoBinds _ _ = EmptyBinds
  67 mkMonoBind mbinds sigs is_rec = MonoBind mbinds sigs is_rec
  68 \end{code}
  69
  70 \begin{code}
  71 instance (Outputable pat, Outputable id) =>
  72                 Outputable (HsBinds id pat) where
  73     ppr binds = ppr_binds binds
  74
  75 ppr_binds EmptyBinds = empty
  76 ppr_binds (ThenBinds binds1 binds2)
  77      = ($$) (ppr_binds binds1) (ppr_binds binds2)
  78 ppr_binds (MonoBind bind sigs is_rec)
  79      = vcat [ifNotPprForUser (ptext rec_str),
  80              vcat (map ppr sigs),
  81              ppr bind
  82        ]
  83      where
  84        rec_str = case is_rec of
  85                    Recursive    -> SLIT("{- rec -}")
  86                    NonRecursive -> SLIT("{- nonrec -}")
  87 \end{code}
  88
  89 %************************************************************************
  90 %*                                                                      *
  91 \subsection{Bindings: @MonoBinds@}
  92 %*                                                                      *
  93 %************************************************************************
  94
  95 Global bindings (where clauses)
  96
  97 \begin{code}
  98 data MonoBinds id pat
  99   = EmptyMonoBinds
 100
 101   | AndMonoBinds    (MonoBinds id pat)
 102                     (MonoBinds id pat)
 103
 104   | PatMonoBind     pat
 105                     (GRHSs id pat)
 106                     SrcLoc
 107
 108   | FunMonoBind     id
 109                     Bool                -- True => infix declaration
 110                     [Match id pat]
 111                     SrcLoc
 112
 113   | VarMonoBind     id                  -- TRANSLATION
 114                     (HsExpr id pat)
 115
 116   | CoreMonoBind    id                  -- TRANSLATION
 117                     CoreExpr            -- No zonking; this is a final CoreExpr with Ids and Types!
 118
 119   | AbsBinds                            -- Binds abstraction; TRANSLATION
 120                 [TyVar]                 -- Type variables
 121                 [id]                    -- Dicts
 122                 [([TyVar], id, id)]     -- (type variables, polymorphic, momonmorphic) triples
 123                 NameSet                 -- Set of *polymorphic* variables that have an INLINE pragma
 124                 (MonoBinds id pat)      -- The "business end"
 125
 126         -- Creates bindings for *new* (polymorphic, overloaded) locals
 127         -- in terms of *old* (monomorphic, non-overloaded) ones.
 128         --
 129         -- See section 9 of static semantics paper for more details.
 130         -- (You can get a PhD for explaining the True Meaning
 131         --  of this last construct.)
 132 \end{code}
 133
 134 What AbsBinds means
 135 ~~~~~~~~~~~~~~~~~~~
 136          AbsBinds tvs
 137                   [d1,d2]
 138                   [(tvs1, f1p, f1m),
 139                    (tvs2, f2p, f2m)]
 140                   BIND
 141 means
 142
 143         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
 144                                       in fm
 145
 146         gp = ...same again, with gm instead of fm
 147
 148 This is a pretty bad translation, because it duplicates all the bindings.
 149 So the desugarer tries to do a better job:
 150
 151         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
 152                                         (fm,gm) -> fm
 153         ..ditto for gp..
 154
 155         p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
 156                                       in (fm,gm)
 157
 158 \begin{code}
 159 -- We keep the invariant that a MonoBinds is only empty
 160 -- if it is exactly EmptyMonoBinds
 161
 162 nullMonoBinds :: MonoBinds id pat -> Bool
 163 nullMonoBinds EmptyMonoBinds         = True
 164 nullMonoBinds other_monobind         = False
 165
 166 andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
 167 andMonoBinds EmptyMonoBinds mb = mb
 168 andMonoBinds mb EmptyMonoBinds = mb
 169 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
 170
 171 andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
 172 andMonoBindList binds
 173   = loop1 binds
 174   where
 175     loop1 [] = EmptyMonoBinds
 176     loop1 (EmptyMonoBinds : binds) = loop1 binds
 177     loop1 (b:bs) = loop2 b bs
 178
 179         -- acc is non-empty
 180     loop2 acc [] = acc
 181     loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
 182     loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
 183 \end{code}
 184
 185 \begin{code}
 186 instance (Outputable id, Outputable pat) =>
 187                 Outputable (MonoBinds id pat) where
 188     ppr mbind = ppr_monobind mbind
 189
 190
 191 ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc
 192 ppr_monobind EmptyMonoBinds = empty
 193 ppr_monobind (AndMonoBinds binds1 binds2)
 194       = ppr_monobind binds1 $$ ppr_monobind binds2
 195
 196 ppr_monobind (PatMonoBind pat grhss locn)
 197       = sep [ppr pat, nest 4 (pprGRHSs False grhss)]
 198
 199 ppr_monobind (FunMonoBind fun inf matches locn)
 200       = pprMatches (False, ppr fun) matches
 201       -- ToDo: print infix if appropriate
 202
 203 ppr_monobind (VarMonoBind name expr)
 204       = sep [ppr name <+> equals, nest 4 (pprExpr expr)]
 205
 206 ppr_monobind (CoreMonoBind name expr)
 207       = sep [ppr name <+> equals, nest 4 (ppr expr)]
 208
 209 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
 210      = sep [ptext SLIT("AbsBinds"),
 211             brackets (interpp'SP tyvars),
 212             brackets (interpp'SP dictvars),
 213             brackets (sep (punctuate comma (map ppr exports))),
 214             brackets (interpp'SP (nameSetToList inlines))]
 215        $$
 216        nest 4 (ppr val_binds)
 217 \end{code}
 218
 219 %************************************************************************
 220 %*                                                                      *
 221 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 222 %*                                                                      *
 223 %************************************************************************
 224
 225 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 226 ``specialise this function to these four types...'') in with type
 227 signatures.  Then all the machinery to move them into place, etc.,
 228 serves for both.
 229
 230 \begin{code}
 231 data Sig name
 232   = Sig         name            -- a bog-std type signature
 233                 (HsType name)
 234                 SrcLoc
 235
 236   | ClassOpSig  name            -- Selector name
 237                 name            -- Default-method name (if any)
 238                 Bool            -- True <=> there is an explicit, programmer-supplied
 239                                 -- default declaration in the class decl
 240                 (HsType name)
 241                 SrcLoc
 242
 243   | SpecSig     name            -- specialise a function or datatype ...
 244                 (HsType name)   -- ... to these types
 245                 SrcLoc
 246
 247   | InlineSig   name            -- INLINE f
 248                 (Maybe Int)     -- phase
 249                 SrcLoc
 250
 251   | NoInlineSig name            -- NOINLINE f
 252                 (Maybe Int)     -- phase
 253                 SrcLoc
 254
 255   | SpecInstSig (HsType name)   -- (Class tys); should be a specialisation of the
 256                                 -- current instance decl
 257                 SrcLoc
 258
 259   | FixSig      (FixitySig name)        -- Fixity declaration
 260
 261   | DeprecSig   (Deprecation name)      -- DEPRECATED
 262                 SrcLoc
 263
 264
 265 data FixitySig name  = FixitySig name Fixity SrcLoc
 266
 267 -- We use exported entities for things to deprecate. Cunning trick (hack?):
 268 -- `IEModuleContents undefined' is used for module deprecation.
 269 data Deprecation name = Deprecation (IE name) DeprecTxt
 270
 271 type DeprecTxt = FAST_STRING    -- reason/explanation for deprecation
 272 \end{code}
 273
 274 \begin{code}
 275 sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name]
 276 sigsForMe f sigs
 277   = filter sig_for_me sigs
 278   where
 279     sig_for_me (Sig         n _ _)                         = f n
 280     sig_for_me (ClassOpSig  n _ _ _ _)                     = f n
 281     sig_for_me (SpecSig     n _ _)                         = f n
 282     sig_for_me (InlineSig   n _   _)                       = f n
 283     sig_for_me (NoInlineSig n _   _)                       = f n
 284     sig_for_me (SpecInstSig _ _)                           = False
 285     sig_for_me (FixSig (FixitySig n _ _))                  = f n
 286     sig_for_me
 287         (DeprecSig (Deprecation (IEModuleContents _) _) _) = False
 288     sig_for_me
 289         (DeprecSig (Deprecation d                    _) _) = f (ieName d)
 290
 291 isFixitySig :: Sig name -> Bool
 292 isFixitySig (FixSig _) = True
 293 isFixitySig _          = False
 294
 295 isClassOpSig :: Sig name -> Bool
 296 isClassOpSig (ClassOpSig _ _ _ _ _) = True
 297 isClassOpSig _                      = False
 298
 299 isPragSig :: Sig name -> Bool
 300         -- Identifies pragmas
 301 isPragSig (SpecSig _ _ _)     = True
 302 isPragSig (InlineSig   _ _ _) = True
 303 isPragSig (NoInlineSig _ _ _) = True
 304 isPragSig (SpecInstSig _ _)   = True
 305 isPragSig (DeprecSig _ _)     = True
 306 isPragSig other               = False
 307 \end{code}
 308
 309 \begin{code}
 310 instance (Outputable name) => Outputable (Sig name) where
 311     ppr sig = ppr_sig sig
 312
 313 ppr_sig :: Outputable name => Sig name -> SDoc
 314 ppr_sig (Sig var ty _)
 315       = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 316
 317 ppr_sig (ClassOpSig var _ _ ty _)
 318       = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 319
 320 ppr_sig (SpecSig var ty _)
 321       = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
 322               nest 4 (ppr ty <+> text "#-}")
 323         ]
 324
 325 ppr_sig (InlineSig var phase _)
 326       = hsep [text "{-# INLINE", ppr_phase phase, ppr var, text "#-}"]
 327
 328 ppr_sig (NoInlineSig var phase _)
 329       = hsep [text "{-# NOINLINE", ppr_phase phase, ppr var, text "#-}"]
 330
 331 ppr_sig (SpecInstSig ty _)
 332       = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
 333
 334 ppr_sig (FixSig fix_sig) = ppr fix_sig
 335
 336 ppr_sig (DeprecSig deprec _) = ppr deprec
 337
 338 instance Outputable name => Outputable (FixitySig name) where
 339   ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
 340
 341 instance Outputable name => Outputable (Deprecation name) where
 342    ppr (Deprecation (IEModuleContents _) txt)
 343       = hsep [text "{-# DEPRECATED",            doubleQuotes (ppr txt), text "#-}"]
 344    ppr (Deprecation thing txt)
 345       = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
 346
 347 ppr_phase :: Maybe Int -> SDoc
 348 ppr_phase Nothing  = empty
 349 ppr_phase (Just n) = int n
 350 \end{code}
 351