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