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