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