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 (sep (punctuate comma (map ppr 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                 name            -- Default-method name (if any)
 222                 Bool            -- True <=> there is an explicit, programmer-supplied
 223                                 -- default declaration in the class decl
 224                 (HsType name)
 225                 SrcLoc
 226
 227   | SpecSig     name            -- specialise a function or datatype ...
 228                 (HsType name)   -- ... to these types
 229                 SrcLoc
 230
 231   | InlineSig   name            -- INLINE f
 232                 (Maybe Int)     -- phase
 233                 SrcLoc
 234
 235   | NoInlineSig name            -- NOINLINE f
 236                 (Maybe Int)     -- phase
 237                 SrcLoc
 238
 239   | SpecInstSig (HsType name)   -- (Class tys); should be a specialisation of the
 240                                 -- current instance decl
 241                 SrcLoc
 242
 243   | FixSig      (FixitySig name)                -- Fixity declaration
 244
 245
 246 data FixitySig name  = FixitySig name Fixity SrcLoc
 247 \end{code}
 248
 249 \begin{code}
 250 sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name]
 251 sigsForMe f sigs
 252   = filter sig_for_me sigs
 253   where
 254     sig_for_me (Sig         n _ _)        = f n
 255     sig_for_me (ClassOpSig  n _ _ _ _)    = f n
 256     sig_for_me (SpecSig     n _ _)        = f n
 257     sig_for_me (InlineSig   n _   _)      = f n
 258     sig_for_me (NoInlineSig n _   _)      = f n
 259     sig_for_me (SpecInstSig _ _)          = False
 260     sig_for_me (FixSig (FixitySig n _ _)) = f n
 261
 262 isFixitySig :: Sig name -> Bool
 263 isFixitySig (FixSig _) = True
 264 isFixitySig _          = False
 265
 266 isClassOpSig :: Sig name -> Bool
 267 isClassOpSig (ClassOpSig _ _ _ _ _) = True
 268 isClassOpSig _                      = False
 269
 270 isPragSig :: Sig name -> Bool
 271         -- Identifies pragmas
 272 isPragSig (SpecSig _ _ _)     = True
 273 isPragSig (InlineSig   _ _ _) = True
 274 isPragSig (NoInlineSig _ _ _) = True
 275 isPragSig (SpecInstSig _ _)   = True
 276 isPragSig other               = False
 277 \end{code}
 278
 279 \begin{code}
 280 instance (Outputable name) => Outputable (Sig name) where
 281     ppr sig = ppr_sig sig
 282
 283 instance Outputable name => Outputable (FixitySig name) where
 284   ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
 285
 286
 287 ppr_sig (Sig var ty _)
 288       = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 289
 290 ppr_sig (ClassOpSig var _ _ ty _)
 291       = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 292
 293 ppr_sig (SpecSig var ty _)
 294       = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
 295               nest 4 (ppr ty <+> text "#-}")
 296         ]
 297
 298 ppr_sig (InlineSig var phase _)
 299         = hsep [text "{-# INLINE", ppr_phase phase, ppr var, text "#-}"]
 300
 301 ppr_sig (NoInlineSig var phase _)
 302         = hsep [text "{-# NOINLINE", ppr_phase phase, ppr var, text "#-}"]
 303
 304 ppr_sig (SpecInstSig ty _)
 305       = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
 306
 307 ppr_sig (FixSig fix_sig) = ppr fix_sig
 308
 309 ppr_phase Nothing = empty
 310 ppr_phase (Just n) = int n
 311 \end{code}
 312