ghc/compiler/hsSyn/HsBinds.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   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, GenId )
  23 import Name             ( OccName, NamedThing(..) )
  24 import BasicTypes       ( RecFlag(..) )
  25 import Outputable
  26 import Bag
  27 import SrcLoc           ( SrcLoc )
  28 import Type             ( GenType )
  29 import TyVar            ( GenTyVar )
  30 \end{code}
  31
  32 %************************************************************************
  33 %*                                                                      *
  34 \subsection{Bindings: @HsBinds@}
  35 %*                                                                      *
  36 %************************************************************************
  37
  38 The following syntax may produce new syntax which is not part of the input,
  39 and which is instead a translation of the input to the typechecker.
  40 Syntax translations are marked TRANSLATION in comments. New empty
  41 productions are useful in development but may not appear in the final
  42 grammar.
  43
  44 Collections of bindings, created by dependency analysis and translation:
  45
  46 \begin{code}
  47 data HsBinds flexi id pat               -- binders and bindees
  48   = EmptyBinds
  49
  50   | ThenBinds   (HsBinds flexi id pat)
  51                 (HsBinds flexi id pat)
  52
  53   | MonoBind    (MonoBinds flexi id pat)
  54                 [Sig id]                -- Empty on typechecker output
  55                 RecFlag
  56 \end{code}
  57
  58 \begin{code}
  59 nullBinds :: HsBinds flexi id pat -> Bool
  60
  61 nullBinds EmptyBinds            = True
  62 nullBinds (ThenBinds b1 b2)     = nullBinds b1 && nullBinds b2
  63 nullBinds (MonoBind b _ _)      = nullMonoBinds b
  64 \end{code}
  65
  66 \begin{code}
  67 instance (Outputable pat, NamedThing id, Outputable id) =>
  68                 Outputable (HsBinds flexi id pat) where
  69     ppr binds = ppr_binds binds
  70
  71 ppr_binds EmptyBinds = empty
  72 ppr_binds (ThenBinds binds1 binds2)
  73      = ($$) (ppr_binds binds1) (ppr_binds binds2)
  74 ppr_binds (MonoBind bind sigs is_rec)
  75      = vcat [ifNotPprForUser (ptext rec_str),
  76              vcat (map ppr sigs),
  77              ppr bind
  78        ]
  79      where
  80        rec_str = case is_rec of
  81                    Recursive    -> SLIT("{- rec -}")
  82                    NonRecursive -> SLIT("{- nonrec -}")
  83 \end{code}
  84
  85 %************************************************************************
  86 %*                                                                      *
  87 \subsection{Bindings: @MonoBinds@}
  88 %*                                                                      *
  89 %************************************************************************
  90
  91 Global bindings (where clauses)
  92
  93 \begin{code}
  94 data MonoBinds flexi id pat
  95   = EmptyMonoBinds
  96
  97   | AndMonoBinds    (MonoBinds flexi id pat)
  98                     (MonoBinds flexi id pat)
  99
 100   | PatMonoBind     pat
 101                     (GRHSsAndBinds flexi id pat)
 102                     SrcLoc
 103
 104   | FunMonoBind     id
 105                     Bool                        -- True => infix declaration
 106                     [Match flexi id pat]        -- must have at least one Match
 107                     SrcLoc
 108
 109   | VarMonoBind     id                  -- TRANSLATION
 110                     (HsExpr flexi id pat)
 111
 112   | CoreMonoBind    id                  -- TRANSLATION
 113                     CoreExpr            -- No zonking; this is a final CoreExpr with Ids and Types!
 114
 115   | AbsBinds                    -- Binds abstraction; TRANSLATION
 116                 [GenTyVar flexi]          -- Type variables
 117                 [id]                      -- Dicts
 118                 [([GenTyVar flexi], id, id)]  -- (type variables, polymorphic, momonmorphic) triples
 119                 (MonoBinds flexi 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 flexi 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 flexi id pat] -> MonoBinds flexi id pat
 161 andMonoBinds binds = foldr AndMonoBinds EmptyMonoBinds binds
 162 \end{code}
 163
 164 \begin{code}
 165 instance (NamedThing id, Outputable id, Outputable pat) =>
 166                 Outputable (MonoBinds flexi id pat) where
 167     ppr mbind = ppr_monobind mbind
 168
 169
 170 ppr_monobind EmptyMonoBinds = empty
 171 ppr_monobind (AndMonoBinds binds1 binds2)
 172       = ($$) (ppr_monobind binds1) (ppr_monobind binds2)
 173
 174 ppr_monobind (PatMonoBind pat grhss_n_binds locn)
 175       = sep [ppr pat, nest 4 (pprGRHSsAndBinds False grhss_n_binds)]
 176
 177 ppr_monobind (FunMonoBind fun inf matches locn)
 178       = pprMatches (False, ppr fun) matches
 179       -- ToDo: print infix if appropriate
 180
 181 ppr_monobind (VarMonoBind name expr)
 182       = sep [ppr name <+> equals, nest 4 (pprExpr expr)]
 183
 184 ppr_monobind (CoreMonoBind name expr)
 185       = sep [ppr name <+> equals, nest 4 (ppr expr)]
 186
 187 ppr_monobind (AbsBinds tyvars dictvars exports val_binds)
 188      = ($$) (sep [ptext SLIT("AbsBinds"),
 189                   brackets (interpp'SP tyvars),
 190                   brackets (interpp'SP dictvars),
 191                   brackets (interpp'SP exports)])
 192                (nest 4 (ppr val_binds))
 193 \end{code}
 194
 195 %************************************************************************
 196 %*                                                                      *
 197 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 198 %*                                                                      *
 199 %************************************************************************
 200
 201 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 202 ``specialise this function to these four types...'') in with type
 203 signatures.  Then all the machinery to move them into place, etc.,
 204 serves for both.
 205
 206 \begin{code}
 207 data Sig name
 208   = Sig         name            -- a bog-std type signature
 209                 (HsType name)
 210                 SrcLoc
 211
 212   | ClassOpSig  name                    -- Selector name
 213                 (Maybe name)            -- Default-method name (if any)
 214                 (HsType name)
 215                 SrcLoc
 216
 217   | SpecSig     name            -- specialise a function or datatype ...
 218                 (HsType name) -- ... to these types
 219                 (Maybe name)    -- ... maybe using this as the code for it
 220                 SrcLoc
 221
 222   | InlineSig   name              -- INLINE f
 223                 SrcLoc
 224
 225   | NoInlineSig name              -- NOINLINE f
 226                 SrcLoc
 227
 228   | SpecInstSig (HsType name)    -- (Class tys); should be a specialisation of the
 229                                   -- current instance decl
 230                 SrcLoc
 231 \end{code}
 232
 233 \begin{code}
 234 sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name]
 235 sigsForMe f sigs
 236   = filter sig_for_me sigs
 237   where
 238     sig_for_me (Sig         n _ _)    = f n
 239     sig_for_me (ClassOpSig  n _ _ _)  = f n
 240     sig_for_me (SpecSig     n _ _ _)  = f n
 241     sig_for_me (InlineSig   n     _)  = f n
 242     sig_for_me (NoInlineSig n     _)  = f n
 243     sig_for_me (SpecInstSig _ _)      = False
 244 \end{code}
 245
 246 \begin{code}
 247 instance (NamedThing name, Outputable name) => Outputable (Sig name) where
 248     ppr sig = ppr_sig sig
 249
 250
 251 ppr_sig (Sig var ty _)
 252       = sep [ppr var <+> ptext SLIT("::"),
 253              nest 4 (ppr ty)]
 254
 255 ppr_sig (ClassOpSig var _ ty _)
 256       = sep [ppr (getOccName var) <+> ptext SLIT("::"),
 257              nest 4 (ppr ty)]
 258
 259 ppr_sig (SpecSig var ty using _)
 260       = sep [ hsep [text "{-# SPECIALIZE", ppr var, ptext SLIT("::")],
 261               nest 4 (hsep [ppr ty, pp_using using, text "#-}"])
 262         ]
 263       where
 264         pp_using Nothing   = empty
 265         pp_using (Just me) = hsep [char '=', ppr me]
 266
 267 ppr_sig (InlineSig var _)
 268         = hsep [text "{-# INLINE", ppr var, text "#-}"]
 269
 270 ppr_sig (NoInlineSig var _)
 271         = hsep [text "{-# NOINLINE", ppr var, text "#-}"]
 272
 273 ppr_sig (SpecInstSig ty _)
 274       = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
 275 \end{code}
 276