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: @BindGroup@, @Bind@, @Sig@, @Bind@.
   7
   8 \begin{code}
   9 module HsBinds where
  10
  11 #include "HsVersions.h"
  12
  13 import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr,
  14                                MatchGroup, pprFunBind,
  15                                GRHSs, pprPatBind )
  16 import {-# SOURCE #-} HsPat  ( LPat )
  17
  18 import HsTypes          ( LHsType, PostTcType )
  19 import Name             ( Name )
  20 import NameSet          ( NameSet, elemNameSet )
  21 import BasicTypes       ( IPName, RecFlag(..), Activation(..), Fixity )
  22 import Outputable
  23 import SrcLoc           ( Located(..), unLoc )
  24 import Var              ( TyVar, DictId, Id )
  25 import Bag              ( Bag, emptyBag, isEmptyBag, bagToList, unionBags )
  26 \end{code}
  27
  28 %************************************************************************
  29 %*                                                                      *
  30 \subsection{Bindings: @BindGroup@}
  31 %*                                                                      *
  32 %************************************************************************
  33
  34 Global bindings (where clauses)
  35
  36 \begin{code}
  37 data HsLocalBinds id    -- Bindings in a 'let' expression
  38                         -- or a 'where' clause
  39   = HsValBinds (HsValBinds id)
  40   | HsIPBinds  (HsIPBinds id)
  41   | EmptyLocalBinds
  42
  43 data HsValBinds id      -- Value bindings (not implicit parameters)
  44   = ValBindsIn                          -- Before typechecking
  45         (LHsBinds id) [LSig id]         -- Not dependency analysed
  46                                         -- Recursive by default
  47
  48   | ValBindsOut                         -- After typechecking
  49         [(RecFlag, LHsBinds id)]        -- Dependency analysed
  50
  51
  52 type LHsBinds id  = Bag (LHsBind id)
  53 type DictBinds id = LHsBinds id         -- Used for dictionary or method bindings
  54 type LHsBind  id  = Located (HsBind id)
  55
  56 data HsBind id
  57   = FunBind     (Located id)
  58                         -- Used for both functions      f x = e
  59                         -- and variables                f = \x -> e
  60                         -- Reason: the Match stuff lets us have an optional
  61                         --         result type sig      f :: a->a = ...mentions a...
  62                         --
  63                         -- This also means that instance decls can only have
  64                         -- FunBinds, so if you change this, you'll need to
  65                         -- change e.g. rnMethodBinds
  66                 Bool    -- True => infix declaration
  67                 (MatchGroup id)
  68                 NameSet         -- After the renamer, this contains a superset of the
  69                                 -- Names of the other binders in this binding group that
  70                                 -- are free in the RHS of the defn
  71                                 -- Before renaming, and after typechecking,
  72                                 -- the field is unused; it's just an error thunk
  73
  74   | PatBind     (LPat id)       -- The pattern is never a simple variable;
  75                                 -- That case is done by FunBind
  76                 (GRHSs id)
  77                 PostTcType      -- Type of the GRHSs
  78                 NameSet         -- Same as for FunBind
  79
  80   | VarBind id (Located (HsExpr id))    -- Dictionary binding and suchlike
  81                                         -- All VarBinds are introduced by the type checker
  82                                         -- Located only for consistency
  83
  84   | AbsBinds                                    -- Binds abstraction; TRANSLATION
  85                 [TyVar]                         -- Type variables
  86                 [DictId]                        -- Dicts
  87                 [([TyVar], id, id, [Prag])]     -- (tvs, poly_id, mono_id, prags)
  88                 (LHsBinds id)                   -- The dictionary bindings and typechecked user bindings
  89                                                 -- mixed up together; you can tell the dict bindings because
  90                                                 -- they are all VarBinds
  91
  92         -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
  93         --
  94         -- Creates bindings for (polymorphic, overloaded) poly_f
  95         -- in terms of monomorphic, non-overloaded mono_f
  96         --
  97         -- Invariants:
  98         --      1. 'binds' binds mono_f
  99         --      2. ftvs is a subset of tvs
 100         --      3. ftvs includes all tyvars free in ds
 101         --
 102         -- See section 9 of static semantics paper for more details.
 103         -- (You can get a PhD for explaining the True Meaning
 104         --  of this last construct.)
 105
 106 placeHolderNames :: NameSet
 107 -- Used for the NameSet in FunBind and PatBind prior to the renamer
 108 placeHolderNames = panic "placeHolderNames"
 109
 110 ------------
 111 instance OutputableBndr id => Outputable (HsLocalBinds id) where
 112   ppr (HsValBinds bs) = ppr bs
 113   ppr (HsIPBinds bs)  = ppr bs
 114   ppr EmptyLocalBinds = empty
 115
 116 instance OutputableBndr id => Outputable (HsValBinds id) where
 117   ppr (ValBindsIn binds sigs)
 118    = vcat [vcat (map ppr sigs),
 119            vcat (map ppr (bagToList binds))
 120                 --  *not* pprLHsBinds because we don't want braces; 'let' and
 121                 -- 'where' include a list of HsBindGroups and we don't want
 122                 -- several groups of bindings each with braces around.
 123        ]
 124   ppr (ValBindsOut sccs) = vcat (map ppr_scc sccs)
 125      where
 126        ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
 127        pp_rec Recursive    = ptext SLIT("rec")
 128        pp_rec NonRecursive = ptext SLIT("nonrec")
 129
 130 pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc
 131 pprLHsBinds binds
 132   | isEmptyLHsBinds binds = empty
 133   | otherwise = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace
 134
 135 ------------
 136 emptyLocalBinds :: HsLocalBinds a
 137 emptyLocalBinds = EmptyLocalBinds
 138
 139 isEmptyLocalBinds :: HsLocalBinds a -> Bool
 140 isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
 141 isEmptyLocalBinds (HsIPBinds ds)  = isEmptyIPBinds ds
 142 isEmptyLocalBinds EmptyLocalBinds = True
 143
 144 isEmptyValBinds :: HsValBinds a -> Bool
 145 isEmptyValBinds (ValBindsIn ds sigs) = isEmptyLHsBinds ds && null sigs
 146 isEmptyValBinds (ValBindsOut ds)     = null ds
 147
 148 emptyValBindsIn, emptyValBindsOut :: HsValBinds a
 149 emptyValBindsIn  = ValBindsIn emptyBag []
 150 emptyValBindsOut = ValBindsOut []
 151
 152 emptyLHsBinds :: LHsBinds id
 153 emptyLHsBinds = emptyBag
 154
 155 isEmptyLHsBinds :: LHsBinds id -> Bool
 156 isEmptyLHsBinds = isEmptyBag
 157
 158 ------------
 159 plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
 160 plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
 161   = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
 162 plusHsValBinds (ValBindsOut ds1) (ValBindsOut ds2)
 163   = ValBindsOut (ds1 ++ ds2)
 164 \end{code}
 165
 166 What AbsBinds means
 167 ~~~~~~~~~~~~~~~~~~~
 168          AbsBinds tvs
 169                   [d1,d2]
 170                   [(tvs1, f1p, f1m),
 171                    (tvs2, f2p, f2m)]
 172                   BIND
 173 means
 174
 175         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
 176                                       in fm
 177
 178         gp = ...same again, with gm instead of fm
 179
 180 This is a pretty bad translation, because it duplicates all the bindings.
 181 So the desugarer tries to do a better job:
 182
 183         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
 184                                         (fm,gm) -> fm
 185         ..ditto for gp..
 186
 187         tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
 188                                        in (fm,gm)
 189
 190 \begin{code}
 191 instance OutputableBndr id => Outputable (HsBind id) where
 192     ppr mbind = ppr_monobind mbind
 193
 194 ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
 195
 196 ppr_monobind (PatBind pat grhss _ _)     = pprPatBind pat grhss
 197 ppr_monobind (VarBind var rhs)           = ppr var <+> equals <+> pprExpr (unLoc rhs)
 198 ppr_monobind (FunBind fun inf matches _) = pprFunBind (unLoc fun) matches
 199       -- ToDo: print infix if appropriate
 200
 201 ppr_monobind (AbsBinds tyvars dictvars exports val_binds)
 202      = sep [ptext SLIT("AbsBinds"),
 203             brackets (interpp'SP tyvars),
 204             brackets (interpp'SP dictvars),
 205             brackets (sep (punctuate comma (map ppr_exp exports)))]
 206        $$
 207        nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
 208                         -- Print type signatures
 209                 $$ pprLHsBinds val_binds )
 210   where
 211     ppr_exp (tvs, gbl, lcl, prags)
 212         = vcat [ppr gbl <+> ptext SLIT("<=") <+> ppr tvs <+> ppr lcl,
 213                 nest 2 (vcat (map (pprPrag gbl) prags))]
 214 \end{code}
 215
 216 %************************************************************************
 217 %*                                                                      *
 218                 Implicit parameter bindings
 219 %*                                                                      *
 220 %************************************************************************
 221
 222 \begin{code}
 223 data HsIPBinds id
 224   = IPBinds
 225         [LIPBind id]
 226         (DictBinds id)  -- Only in typechecker output; binds
 227                         -- uses of the implicit parameters
 228
 229 isEmptyIPBinds :: HsIPBinds id -> Bool
 230 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyBag ds
 231
 232 type LIPBind id = Located (IPBind id)
 233
 234 -- | Implicit parameter bindings.
 235 data IPBind id
 236   = IPBind
 237         (IPName id)
 238         (LHsExpr id)
 239
 240 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
 241   ppr (IPBinds bs ds) = vcat (map ppr bs)
 242                         $$ pprLHsBinds ds
 243
 244 instance (OutputableBndr id) => Outputable (IPBind id) where
 245   ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
 246 \end{code}
 247
 248
 249 %************************************************************************
 250 %*                                                                      *
 251 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 252 %*                                                                      *
 253 %************************************************************************
 254
 255 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 256 ``specialise this function to these four types...'') in with type
 257 signatures.  Then all the machinery to move them into place, etc.,
 258 serves for both.
 259
 260 \begin{code}
 261 type LSig name = Located (Sig name)
 262
 263 data Sig name
 264   = Sig         (Located name)  -- a bog-std type signature
 265                 (LHsType name)
 266
 267   | SpecSig     (Located name)  -- specialise a function or datatype ...
 268                 (LHsType name)  -- ... to these types
 269
 270   | InlineSig   Bool            -- True <=> INLINE f, False <=> NOINLINE f
 271                 (Located name)  -- Function name
 272                 Activation      -- When inlining is *active*
 273
 274   | SpecInstSig (LHsType name)  -- (Class tys); should be a specialisation of the
 275                                 -- current instance decl
 276
 277   | FixSig      (FixitySig name)        -- Fixity declaration
 278
 279 type LFixitySig name = Located (FixitySig name)
 280 data FixitySig name = FixitySig (Located name) Fixity
 281
 282 -- A Prag conveys pragmas from the type checker to the desugarer
 283 data Prag
 284   = InlinePrag
 285         Bool            -- True <=> INLINE, False <=> NOINLINE
 286         Activation
 287
 288   | SpecPrag
 289         (HsExpr Id)     -- An expression, of the given specialised type, which
 290         PostTcType      -- specialises the polymorphic function
 291         [Id]            -- Dicts mentioned free in the expression
 292
 293 isInlinePrag (InlinePrag _ _) = True
 294 isInlinePrag prag             = False
 295
 296 isSpecPrag (SpecPrag _ _ _) = True
 297 isSpecPrag prag             = False
 298 \end{code}
 299
 300 \begin{code}
 301 okBindSig :: NameSet -> LSig Name -> Bool
 302 okBindSig ns sig = sigForThisGroup ns sig
 303
 304 okHsBootSig :: LSig Name -> Bool
 305 okHsBootSig (L _ (Sig  _ _)) = True
 306 okHsBootSig (L _ (FixSig _)) = True
 307 okHsBootSig sig              = False
 308
 309 okClsDclSig :: LSig Name -> Bool
 310 okClsDclSig (L _ (SpecInstSig _)) = False
 311 okClsDclSig sig                   = True        -- All others OK
 312
 313 okInstDclSig :: NameSet -> LSig Name -> Bool
 314 okInstDclSig ns lsig@(L _ sig) = ok ns sig
 315   where
 316     ok ns (Sig _ _)       = False
 317     ok ns (FixSig _)      = False
 318     ok ns (SpecInstSig _) = True
 319     ok ns sig             = sigForThisGroup ns lsig
 320
 321 sigForThisGroup :: NameSet -> LSig Name -> Bool
 322 sigForThisGroup ns sig
 323   = case sigName sig of
 324         Nothing -> False
 325         Just n  -> n `elemNameSet` ns
 326
 327 sigName :: LSig name -> Maybe name
 328 sigName (L _ sig) = f sig
 329  where
 330     f (Sig         n _)        = Just (unLoc n)
 331     f (SpecSig     n _)        = Just (unLoc n)
 332     f (InlineSig _ n _)        = Just (unLoc n)
 333     f (FixSig (FixitySig n _)) = Just (unLoc n)
 334     f other                     = Nothing
 335
 336 isFixityLSig :: LSig name -> Bool
 337 isFixityLSig (L _ (FixSig _)) = True
 338 isFixityLSig _                = False
 339
 340 isVanillaLSig :: LSig name -> Bool
 341 isVanillaLSig (L _(Sig name _)) = True
 342 isVanillaLSig sig               = False
 343
 344 isSpecLSig :: LSig name -> Bool
 345 isSpecLSig (L _(SpecSig name _)) = True
 346 isSpecLSig sig                   = False
 347
 348 isSpecInstLSig (L _ (SpecInstSig _)) = True
 349 isSpecInstLSig sig                   = False
 350
 351 isPragLSig :: LSig name -> Bool
 352         -- Identifies pragmas
 353 isPragLSig (L _ (SpecSig _ _))     = True
 354 isPragLSig (L _ (InlineSig _ _ _)) = True
 355 isPragLSig other                   = False
 356
 357 hsSigDoc (Sig        _ _)         = ptext SLIT("type signature")
 358 hsSigDoc (SpecSig    _ _)         = ptext SLIT("SPECIALISE pragma")
 359 hsSigDoc (InlineSig True  _ _)    = ptext SLIT("INLINE pragma")
 360 hsSigDoc (InlineSig False _ _)    = ptext SLIT("NOINLINE pragma")
 361 hsSigDoc (SpecInstSig _)          = ptext SLIT("SPECIALISE instance pragma")
 362 hsSigDoc (FixSig (FixitySig _ _)) = ptext SLIT("fixity declaration")
 363 \end{code}
 364
 365 Signature equality is used when checking for duplicate signatures
 366
 367 \begin{code}
 368 eqHsSig :: LSig Name -> LSig Name -> Bool
 369 eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
 370 eqHsSig (L _ (Sig n1 _))                (L _ (Sig n2 _))                = unLoc n1 == unLoc n2
 371 eqHsSig (L _ (InlineSig b1 n1 _))       (L _ (InlineSig b2 n2 _))       = b1 == b2 && unLoc n1 == unLoc n2
 372         -- For specialisations, we don't have equality over
 373         -- HsType, so it's not convenient to spot duplicate
 374         -- specialisations here.  Check for this later, when we're in Type land
 375 eqHsSig _other1 _other2 = False
 376 \end{code}
 377
 378 \begin{code}
 379 instance (OutputableBndr name) => Outputable (Sig name) where
 380     ppr sig = ppr_sig sig
 381
 382 ppr_sig :: OutputableBndr name => Sig name -> SDoc
 383 ppr_sig (Sig var ty)              = pprVarSig (unLoc var) ty
 384 ppr_sig (FixSig fix_sig)          = ppr fix_sig
 385 ppr_sig (SpecSig var ty)          = pragBrackets (pprSpec var ty)
 386 ppr_sig (InlineSig inl var phase) = pragBrackets (pprInline var inl phase)
 387 ppr_sig (SpecInstSig ty)          = pragBrackets (ptext SLIT("SPECIALIZE instance") <+> ppr ty)
 388
 389 instance Outputable name => Outputable (FixitySig name) where
 390   ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
 391
 392 pragBrackets :: SDoc -> SDoc
 393 pragBrackets doc = ptext SLIT("{-#") <+> doc <+> ptext SLIT("#-}")
 394
 395 pprInline :: Outputable id => id -> Bool -> Activation -> SDoc
 396 pprInline var True  phase = hsep [ptext SLIT("INLINE"),   ppr phase, ppr var]
 397 pprInline var False phase = hsep [ptext SLIT("NOINLINE"), ppr phase, ppr var]
 398
 399 pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc
 400 pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)]
 401
 402 pprSpec :: (Outputable id, Outputable ty) => id -> ty -> SDoc
 403 pprSpec var ty = sep [ptext SLIT("SPECIALIZE") <+> pprVarSig var ty]
 404
 405 pprPrag :: Outputable id => id -> Prag -> SDoc
 406 pprPrag var (InlinePrag inl act) = pprInline var inl act
 407 pprPrag var (SpecPrag expr ty _) = pprSpec var ty
 408 \end{code}