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