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, pprGRHSsAndBinds, GRHSsAndBinds )
  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(..) )
  25 import Outputable
  26 import Bag
  27 import SrcLoc           ( SrcLoc )
  28 import Var              ( GenTyVar )
  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 flexi id pat               -- binders and bindees
  47   = EmptyBinds
  48
  49   | ThenBinds   (HsBinds flexi id pat)
  50                 (HsBinds flexi id pat)
  51
  52   | MonoBind    (MonoBinds flexi id pat)
  53                 [Sig id]                -- Empty on typechecker output
  54                 RecFlag
  55 \end{code}
  56
  57 \begin{code}
  58 nullBinds :: HsBinds flexi 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 flexi 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 flexi id pat
  94   = EmptyMonoBinds
  95
  96   | AndMonoBinds    (MonoBinds flexi id pat)
  97                     (MonoBinds flexi id pat)
  98
  99   | PatMonoBind     pat
 100                     (GRHSsAndBinds flexi id pat)
 101                     SrcLoc
 102
 103   | FunMonoBind     id
 104                     Bool                        -- True => infix declaration
 105                     [Match flexi id pat]        -- must have at least one Match
 106                     SrcLoc
 107
 108   | VarMonoBind     id                  -- TRANSLATION
 109                     (HsExpr flexi 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                 [GenTyVar flexi]          -- Type variables
 116                 [id]                      -- Dicts
 117                 [([GenTyVar flexi], id, id)]  -- (type variables, polymorphic, momonmorphic) triples
 118                 (MonoBinds flexi 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 flexi 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 flexi id pat -> MonoBinds flexi id pat -> MonoBinds flexi id pat
 160 andMonoBinds EmptyMonoBinds mb = mb
 161 andMonoBinds mb EmptyMonoBinds = mb
 162 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
 163
 164 andMonoBindList :: [MonoBinds flexi id pat] -> MonoBinds flexi 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 flexi 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_n_binds locn)
 179       = sep [ppr pat, nest 4 (pprGRHSsAndBinds False grhss_n_binds)]
 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 \end{code}
 236
 237 \begin{code}
 238 sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name]
 239 sigsForMe f sigs
 240   = filter sig_for_me sigs
 241   where
 242     sig_for_me (Sig         n _ _)    = f n
 243     sig_for_me (ClassOpSig  n _ _ _)  = f n
 244     sig_for_me (SpecSig     n _ _ _)  = f n
 245     sig_for_me (InlineSig   n     _)  = f n
 246     sig_for_me (NoInlineSig n     _)  = f n
 247     sig_for_me (SpecInstSig _ _)      = False
 248 \end{code}
 249
 250 \begin{code}
 251 instance (NamedThing name, Outputable name) => Outputable (Sig name) where
 252     ppr sig = ppr_sig sig
 253
 254
 255 ppr_sig (Sig var ty _)
 256       = sep [ppr var <+> ptext SLIT("::"),
 257              nest 4 (ppr ty)]
 258
 259 ppr_sig (ClassOpSig var _ ty _)
 260       = sep [ppr (getOccName var) <+> ptext SLIT("::"),
 261              nest 4 (ppr ty)]
 262
 263 ppr_sig (SpecSig var ty using _)
 264       = sep [ hsep [text "{-# SPECIALIZE", ppr var, ptext SLIT("::")],
 265               nest 4 (hsep [ppr ty, pp_using using, text "#-}"])
 266         ]
 267       where
 268         pp_using Nothing   = empty
 269         pp_using (Just me) = hsep [char '=', ppr me]
 270
 271 ppr_sig (InlineSig var _)
 272         = hsep [text "{-# INLINE", ppr var, text "#-}"]
 273
 274 ppr_sig (NoInlineSig var _)
 275         = hsep [text "{-# NOINLINE", ppr var, text "#-}"]
 276
 277 ppr_sig (SpecInstSig ty _)
 278       = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
 279 \end{code}
 280