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