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