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