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 Name             ( OccName, NamedThing(..) )
  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, NamedThing id, 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                 (MonoBinds id pat)      -- The "business end"
 119
 120         -- Creates bindings for *new* (polymorphic, overloaded) locals
 121         -- in terms of *old* (monomorphic, non-overloaded) ones.
 122         --
 123         -- See section 9 of static semantics paper for more details.
 124         -- (You can get a PhD for explaining the True Meaning
 125         --  of this last construct.)
 126 \end{code}
 127
 128 What AbsBinds means
 129 ~~~~~~~~~~~~~~~~~~~
 130          AbsBinds tvs
 131                   [d1,d2]
 132                   [(tvs1, f1p, f1m),
 133                    (tvs2, f2p, f2m)]
 134                   BIND
 135 means
 136
 137         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
 138                                       in fm
 139
 140         gp = ...same again, with gm instead of fm
 141
 142 This is a pretty bad translation, because it duplicates all the bindings.
 143 So the desugarer tries to do a better job:
 144
 145         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
 146                                         (fm,gm) -> fm
 147         ..ditto for gp..
 148
 149         p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
 150                                       in (fm,gm)
 151
 152 \begin{code}
 153 nullMonoBinds :: MonoBinds id pat -> Bool
 154
 155 nullMonoBinds EmptyMonoBinds         = True
 156 nullMonoBinds (AndMonoBinds bs1 bs2) = nullMonoBinds bs1 && nullMonoBinds bs2
 157 nullMonoBinds other_monobind         = False
 158
 159 andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
 160 andMonoBinds EmptyMonoBinds mb = mb
 161 andMonoBinds mb EmptyMonoBinds = mb
 162 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
 163
 164 andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
 165 andMonoBindList binds = foldr AndMonoBinds EmptyMonoBinds binds
 166 \end{code}
 167
 168 \begin{code}
 169 instance (NamedThing id, Outputable id, Outputable pat) =>
 170                 Outputable (MonoBinds id pat) where
 171     ppr mbind = ppr_monobind mbind
 172
 173
 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                (nest 4 (ppr val_binds))
 197 \end{code}
 198
 199 %************************************************************************
 200 %*                                                                      *
 201 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 202 %*                                                                      *
 203 %************************************************************************
 204
 205 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 206 ``specialise this function to these four types...'') in with type
 207 signatures.  Then all the machinery to move them into place, etc.,
 208 serves for both.
 209
 210 \begin{code}
 211 data Sig name
 212   = Sig         name            -- a bog-std type signature
 213                 (HsType name)
 214                 SrcLoc
 215
 216   | ClassOpSig  name            -- Selector name
 217                 (Maybe name)    -- Default-method name (if any)
 218                 (HsType name)
 219                 SrcLoc
 220
 221   | SpecSig     name            -- specialise a function or datatype ...
 222                 (HsType name)   -- ... to these types
 223                 (Maybe name)    -- ... maybe using this as the code for it
 224                 SrcLoc
 225
 226   | InlineSig   name            -- INLINE f
 227                 SrcLoc
 228
 229   | NoInlineSig name            -- NOINLINE f
 230                 SrcLoc
 231
 232   | SpecInstSig (HsType name)   -- (Class tys); should be a specialisation of the
 233                                 -- current instance decl
 234                 SrcLoc
 235
 236   | FixSig      (FixitySig name)                -- Fixity declaration
 237
 238
 239 data FixitySig name  = FixitySig name Fixity SrcLoc
 240 \end{code}
 241
 242 \begin{code}
 243 sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name]
 244 sigsForMe f sigs
 245   = filter sig_for_me sigs
 246   where
 247     sig_for_me (Sig         n _ _)        = f n
 248     sig_for_me (ClassOpSig  n _ _ _)      = f n
 249     sig_for_me (SpecSig     n _ _ _)      = f n
 250     sig_for_me (InlineSig   n     _)      = f n
 251     sig_for_me (NoInlineSig n     _)      = f n
 252     sig_for_me (SpecInstSig _ _)          = False
 253     sig_for_me (FixSig (FixitySig n _ _)) = f n
 254
 255 nonFixitySigs :: [Sig name] -> [Sig name]
 256 nonFixitySigs sigs = filter not_fix sigs
 257                    where
 258                      not_fix (FixSig _) = False
 259                      not_fix other      = True
 260 \end{code}
 261
 262 \begin{code}
 263 instance (NamedThing name, Outputable name) => Outputable (Sig name) where
 264     ppr sig = ppr_sig sig
 265
 266 instance Outputable name => Outputable (FixitySig name) where
 267   ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
 268
 269
 270 ppr_sig (Sig var ty _)
 271       = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 272
 273 ppr_sig (ClassOpSig var _ ty _)
 274       = sep [ppr (getOccName var) <+> dcolon, nest 4 (ppr ty)]
 275
 276 ppr_sig (SpecSig var ty using _)
 277       = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
 278               nest 4 (hsep [ppr ty, pp_using using, text "#-}"])
 279         ]
 280       where
 281         pp_using Nothing   = empty
 282         pp_using (Just me) = hsep [char '=', ppr me]
 283
 284 ppr_sig (InlineSig var _)
 285         = hsep [text "{-# INLINE", ppr var, text "#-}"]
 286
 287 ppr_sig (NoInlineSig var _)
 288         = hsep [text "{-# NOINLINE", ppr var, text "#-}"]
 289
 290 ppr_sig (SpecInstSig ty _)
 291       = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
 292
 293 ppr_sig (FixSig fix_sig) = ppr fix_sig
 294 \end{code}
 295