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