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: @HsBinds@, @Bind@, @Sig@, @MonoBinds@.
   7
   8 \begin{code}
   9 module HsBinds where
  10
  11 #include "HsVersions.h"
  12
  13 import {-# SOURCE #-} HsExpr    ( pprExpr, HsExpr )
  14 import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSs, GRHSs )
  15
  16 -- friends:
  17 import HsTypes          ( HsType, cmpHsType )
  18 import HsImpExp         ( IE(..), ieName )
  19 import CoreSyn          ( CoreExpr )
  20 import PprCore          ()         -- Instances for Outputable
  21
  22 --others:
  23 import Id               ( Id )
  24 import Name             ( Name, isUnboundName )
  25 import NameSet          ( NameSet, elemNameSet, nameSetToList )
  26 import BasicTypes       ( RecFlag(..), Fixity )
  27 import Outputable
  28 import Bag
  29 import SrcLoc           ( SrcLoc )
  30 import Var              ( TyVar )
  31 import Util             ( thenCmp )
  32 \end{code}
  33
  34 %************************************************************************
  35 %*                                                                      *
  36 \subsection{Bindings: @HsBinds@}
  37 %*                                                                      *
  38 %************************************************************************
  39
  40 The following syntax may produce new syntax which is not part of the input,
  41 and which is instead a translation of the input to the typechecker.
  42 Syntax translations are marked TRANSLATION in comments. New empty
  43 productions are useful in development but may not appear in the final
  44 grammar.
  45
  46 Collections of bindings, created by dependency analysis and translation:
  47
  48 \begin{code}
  49 data HsBinds id pat             -- binders and bindees
  50   = EmptyBinds
  51
  52   | ThenBinds   (HsBinds id pat)
  53                 (HsBinds id pat)
  54
  55   | MonoBind    (MonoBinds id pat)
  56                 [Sig id]                -- Empty on typechecker output
  57                 RecFlag
  58 \end{code}
  59
  60 \begin{code}
  61 nullBinds :: HsBinds id pat -> Bool
  62
  63 nullBinds EmptyBinds            = True
  64 nullBinds (ThenBinds b1 b2)     = nullBinds b1 && nullBinds b2
  65 nullBinds (MonoBind b _ _)      = nullMonoBinds b
  66
  67 mkMonoBind :: MonoBinds id pat -> [Sig id] -> RecFlag -> HsBinds id pat
  68 mkMonoBind EmptyMonoBinds _ _ = EmptyBinds
  69 mkMonoBind mbinds sigs is_rec = MonoBind mbinds sigs is_rec
  70 \end{code}
  71
  72 \begin{code}
  73 instance (Outputable pat, Outputable id) =>
  74                 Outputable (HsBinds id pat) where
  75     ppr binds = ppr_binds binds
  76
  77 ppr_binds EmptyBinds = empty
  78 ppr_binds (ThenBinds binds1 binds2)
  79      = ($$) (ppr_binds binds1) (ppr_binds binds2)
  80 ppr_binds (MonoBind bind sigs is_rec)
  81      = vcat [ifNotPprForUser (ptext rec_str),
  82              vcat (map ppr sigs),
  83              ppr bind
  84        ]
  85      where
  86        rec_str = case is_rec of
  87                    Recursive    -> SLIT("{- rec -}")
  88                    NonRecursive -> SLIT("{- nonrec -}")
  89 \end{code}
  90
  91 %************************************************************************
  92 %*                                                                      *
  93 \subsection{Bindings: @MonoBinds@}
  94 %*                                                                      *
  95 %************************************************************************
  96
  97 Global bindings (where clauses)
  98
  99 \begin{code}
 100 data MonoBinds id pat
 101   = EmptyMonoBinds
 102
 103   | AndMonoBinds    (MonoBinds id pat)
 104                     (MonoBinds id pat)
 105
 106   | FunMonoBind     id          -- Used for both functions      f x = e
 107                                 -- and variables                f = \x -> e
 108                                 -- Reason: the Match stuff lets us have an optional
 109                                 --         result type sig      f :: a->a = ...mentions a...
 110                     Bool                -- True => infix declaration
 111                     [Match id pat]
 112                     SrcLoc
 113
 114   | PatMonoBind     pat         -- The pattern is never a simple variable;
 115                                 -- That case is done by FunMonoBind
 116                     (GRHSs id pat)
 117                     SrcLoc
 118
 119   | VarMonoBind     id                  -- TRANSLATION
 120                     (HsExpr id pat)
 121
 122   | CoreMonoBind    id                  -- TRANSLATION
 123                     CoreExpr            -- No zonking; this is a final CoreExpr with Ids and Types!
 124
 125   | AbsBinds                            -- Binds abstraction; TRANSLATION
 126                 [TyVar]                 -- Type variables
 127                 [id]                    -- Dicts
 128                 [([TyVar], id, id)]     -- (type variables, polymorphic, momonmorphic) triples
 129                 NameSet                 -- Set of *polymorphic* variables that have an INLINE pragma
 130                 (MonoBinds id pat)      -- The "business end"
 131
 132         -- Creates bindings for *new* (polymorphic, overloaded) locals
 133         -- in terms of *old* (monomorphic, non-overloaded) ones.
 134         --
 135         -- See section 9 of static semantics paper for more details.
 136         -- (You can get a PhD for explaining the True Meaning
 137         --  of this last construct.)
 138 \end{code}
 139
 140 What AbsBinds means
 141 ~~~~~~~~~~~~~~~~~~~
 142          AbsBinds tvs
 143                   [d1,d2]
 144                   [(tvs1, f1p, f1m),
 145                    (tvs2, f2p, f2m)]
 146                   BIND
 147 means
 148
 149         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
 150                                       in fm
 151
 152         gp = ...same again, with gm instead of fm
 153
 154 This is a pretty bad translation, because it duplicates all the bindings.
 155 So the desugarer tries to do a better job:
 156
 157         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
 158                                         (fm,gm) -> fm
 159         ..ditto for gp..
 160
 161         p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
 162                                       in (fm,gm)
 163
 164 \begin{code}
 165 -- We keep the invariant that a MonoBinds is only empty
 166 -- if it is exactly EmptyMonoBinds
 167
 168 nullMonoBinds :: MonoBinds id pat -> Bool
 169 nullMonoBinds EmptyMonoBinds         = True
 170 nullMonoBinds other_monobind         = False
 171
 172 andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
 173 andMonoBinds EmptyMonoBinds mb = mb
 174 andMonoBinds mb EmptyMonoBinds = mb
 175 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
 176
 177 andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
 178 andMonoBindList binds
 179   = loop1 binds
 180   where
 181     loop1 [] = EmptyMonoBinds
 182     loop1 (EmptyMonoBinds : binds) = loop1 binds
 183     loop1 (b:bs) = loop2 b bs
 184
 185         -- acc is non-empty
 186     loop2 acc [] = acc
 187     loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
 188     loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
 189 \end{code}
 190
 191
 192 \begin{code}
 193 instance (Outputable id, Outputable pat) =>
 194                 Outputable (MonoBinds id pat) where
 195     ppr mbind = ppr_monobind mbind
 196
 197
 198 ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc
 199 ppr_monobind EmptyMonoBinds = empty
 200 ppr_monobind (AndMonoBinds binds1 binds2)
 201       = ppr_monobind binds1 $$ ppr_monobind binds2
 202
 203 ppr_monobind (PatMonoBind pat grhss locn)
 204       = sep [ppr pat, nest 4 (pprGRHSs False grhss)]
 205
 206 ppr_monobind (FunMonoBind fun inf matches locn)
 207       = pprMatches (False, ppr fun) matches
 208       -- ToDo: print infix if appropriate
 209
 210 ppr_monobind (VarMonoBind name expr)
 211       = sep [ppr name <+> equals, nest 4 (pprExpr expr)]
 212
 213 ppr_monobind (CoreMonoBind name expr)
 214       = sep [ppr name <+> equals, nest 4 (ppr expr)]
 215
 216 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
 217      = sep [ptext SLIT("AbsBinds"),
 218             brackets (interpp'SP tyvars),
 219             brackets (interpp'SP dictvars),
 220             brackets (sep (punctuate comma (map ppr exports))),
 221             brackets (interpp'SP (nameSetToList inlines))]
 222        $$
 223        nest 4 (ppr val_binds)
 224 \end{code}
 225
 226 %************************************************************************
 227 %*                                                                      *
 228 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 229 %*                                                                      *
 230 %************************************************************************
 231
 232 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 233 ``specialise this function to these four types...'') in with type
 234 signatures.  Then all the machinery to move them into place, etc.,
 235 serves for both.
 236
 237 \begin{code}
 238 data Sig name
 239   = Sig         name            -- a bog-std type signature
 240                 (HsType name)
 241                 SrcLoc
 242
 243   | ClassOpSig  name            -- Selector name
 244                 name            -- Default-method name (if any)
 245                 Bool            -- True <=> there is an explicit, programmer-supplied
 246                                 -- default declaration in the class decl
 247                 (HsType name)
 248                 SrcLoc
 249
 250   | SpecSig     name            -- specialise a function or datatype ...
 251                 (HsType name)   -- ... to these types
 252                 SrcLoc
 253
 254   | InlineSig   name            -- INLINE f
 255                 (Maybe Int)     -- phase
 256                 SrcLoc
 257
 258   | NoInlineSig name            -- NOINLINE f
 259                 (Maybe Int)     -- phase
 260                 SrcLoc
 261
 262   | SpecInstSig (HsType name)   -- (Class tys); should be a specialisation of the
 263                                 -- current instance decl
 264                 SrcLoc
 265
 266   | FixSig      (FixitySig name)        -- Fixity declaration
 267
 268   | DeprecSig   (Deprecation name)      -- DEPRECATED
 269                 SrcLoc
 270
 271 data FixitySig name  = FixitySig name Fixity SrcLoc
 272
 273 -- We use exported entities for things to deprecate. Cunning trick (hack?):
 274 -- `IEModuleContents undefined' is used for module deprecation.
 275 data Deprecation name = Deprecation (IE name) DeprecTxt
 276
 277 type DeprecTxt = FAST_STRING    -- reason/explanation for deprecation
 278 \end{code}
 279
 280 \begin{code}
 281 okBindSig :: NameSet -> Sig Name -> Bool
 282 okBindSig ns (ClassOpSig _ _ _ _ _)                             = False
 283 okBindSig ns sig = sigForThisGroup ns sig
 284
 285 okClsDclSig :: NameSet -> Sig Name -> Bool
 286 okClsDclSig ns (Sig _ _ _)                                        = False
 287 okClsDclSig ns sig = sigForThisGroup ns sig
 288
 289 okInstDclSig :: NameSet -> Sig Name -> Bool
 290 okInstDclSig ns (Sig _ _ _)                                        = False
 291 okInstDclSig ns (FixSig _)                                         = False
 292 okInstDclSig ns (SpecInstSig _ _)                                  = True
 293 okInstDclSig ns sig = sigForThisGroup ns sig
 294
 295 sigForThisGroup ns sig
 296   = case sigName sig of
 297         Nothing                  -> False
 298         Just n | isUnboundName n -> True        -- Don't complain about an unbound name again
 299                | otherwise       -> n `elemNameSet` ns
 300
 301 sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name]
 302 sigsForMe f sigs
 303   = filter sig_for_me sigs
 304   where
 305     sig_for_me sig = case sigName sig of
 306                         Nothing -> False
 307                         Just n  -> f n
 308
 309 sigName :: Sig name -> Maybe name
 310 sigName (Sig         n _ _)             = Just n
 311 sigName (ClassOpSig  n _ _ _ _)         = Just n
 312 sigName (SpecSig     n _ _)             = Just n
 313 sigName (InlineSig   n _   _)           = Just n
 314 sigName (NoInlineSig n _   _)           = Just n
 315 sigName (FixSig (FixitySig n _ _))      = Just n
 316 sigName (DeprecSig (Deprecation d _) _) = case d of
 317                                             IEModuleContents _ -> Nothing
 318                                             other              -> Just (ieName d)
 319 sigName other                           = Nothing
 320
 321 isFixitySig :: Sig name -> Bool
 322 isFixitySig (FixSig _) = True
 323 isFixitySig _          = False
 324
 325 isClassOpSig :: Sig name -> Bool
 326 isClassOpSig (ClassOpSig _ _ _ _ _) = True
 327 isClassOpSig _                      = False
 328
 329 isPragSig :: Sig name -> Bool
 330         -- Identifies pragmas
 331 isPragSig (SpecSig _ _ _)     = True
 332 isPragSig (InlineSig   _ _ _) = True
 333 isPragSig (NoInlineSig _ _ _) = True
 334 isPragSig (SpecInstSig _ _)   = True
 335 isPragSig (DeprecSig _ _)     = True
 336 isPragSig other               = False
 337 \end{code}
 338
 339 \begin{code}
 340 hsSigDoc (Sig        _ _ loc)         = (SLIT("type signature"),loc)
 341 hsSigDoc (ClassOpSig _ _ _ _ loc)     = (SLIT("class-method type signature"), loc)
 342 hsSigDoc (SpecSig    _ _ loc)         = (SLIT("SPECIALISE pragma"),loc)
 343 hsSigDoc (InlineSig  _ _    loc)      = (SLIT("INLINE pragma"),loc)
 344 hsSigDoc (NoInlineSig  _ _  loc)      = (SLIT("NOINLINE pragma"),loc)
 345 hsSigDoc (SpecInstSig _ loc)          = (SLIT("SPECIALISE instance pragma"),loc)
 346 hsSigDoc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc)
 347 hsSigDoc (DeprecSig _ loc)            = (SLIT("DEPRECATED pragma"), loc)
 348 \end{code}
 349
 350 \begin{code}
 351 instance (Outputable name) => Outputable (Sig name) where
 352     ppr sig = ppr_sig sig
 353
 354 ppr_sig :: Outputable name => Sig name -> SDoc
 355 ppr_sig (Sig var ty _)
 356       = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 357
 358 ppr_sig (ClassOpSig var _ _ ty _)
 359       = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 360
 361 ppr_sig (SpecSig var ty _)
 362       = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
 363               nest 4 (ppr ty <+> text "#-}")
 364         ]
 365
 366 ppr_sig (InlineSig var phase _)
 367       = hsep [text "{-# INLINE", ppr_phase phase, ppr var, text "#-}"]
 368
 369 ppr_sig (NoInlineSig var phase _)
 370       = hsep [text "{-# NOINLINE", ppr_phase phase, ppr var, text "#-}"]
 371
 372 ppr_sig (SpecInstSig ty _)
 373       = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
 374
 375 ppr_sig (FixSig fix_sig) = ppr fix_sig
 376
 377 ppr_sig (DeprecSig deprec _) = ppr deprec
 378
 379 instance Outputable name => Outputable (FixitySig name) where
 380   ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
 381
 382 instance Outputable name => Outputable (Deprecation name) where
 383    ppr (Deprecation (IEModuleContents _) txt)
 384       = hsep [text "{-# DEPRECATED",            doubleQuotes (ppr txt), text "#-}"]
 385    ppr (Deprecation thing txt)
 386       = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
 387
 388 ppr_phase :: Maybe Int -> SDoc
 389 ppr_phase Nothing  = empty
 390 ppr_phase (Just n) = int n
 391 \end{code}
 392
 393 Checking for distinct signatures; oh, so boring
 394
 395
 396 \begin{code}
 397 cmpHsSig :: Sig Name -> Sig Name -> Ordering
 398 cmpHsSig (Sig n1 _ _)         (Sig n2 _ _)         = n1 `compare` n2
 399 cmpHsSig (DeprecSig (Deprecation ie1 _) _)
 400          (DeprecSig (Deprecation ie2 _) _)         = cmp_ie ie1 ie2
 401 cmpHsSig (InlineSig n1 _ _)   (InlineSig n2 _ _)   = n1 `compare` n2
 402 cmpHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 `compare` n2
 403
 404 cmpHsSig (SpecInstSig ty1 _)  (SpecInstSig ty2 _)  = cmpHsType compare ty1 ty2
 405 cmpHsSig (SpecSig n1 ty1 _)   (SpecSig n2 ty2 _)
 406   = -- may have many specialisations for one value;
 407     -- but not ones that are exactly the same...
 408     thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2)
 409
 410 cmpHsSig other_1 other_2                                        -- Tags *must* be different
 411   | (sig_tag other_1) _LT_ (sig_tag other_2) = LT
 412   | otherwise                                = GT
 413
 414 cmp_ie :: IE Name -> IE Name -> Ordering
 415 cmp_ie (IEVar            n1  ) (IEVar            n2  ) = n1 `compare` n2
 416 cmp_ie (IEThingAbs       n1  ) (IEThingAbs       n2  ) = n1 `compare` n2
 417 cmp_ie (IEThingAll       n1  ) (IEThingAll       n2  ) = n1 `compare` n2
 418 -- Hmmm...
 419 cmp_ie (IEThingWith      n1 _) (IEThingWith      n2 _) = n1 `compare` n2
 420 cmp_ie (IEModuleContents _   ) (IEModuleContents _   ) = EQ
 421
 422 sig_tag (Sig n1 _ _)               = (ILIT(1) :: FAST_INT)
 423 sig_tag (SpecSig n1 _ _)           = ILIT(2)
 424 sig_tag (InlineSig n1 _ _)         = ILIT(3)
 425 sig_tag (NoInlineSig n1 _ _)       = ILIT(4)
 426 sig_tag (SpecInstSig _ _)          = ILIT(5)
 427 sig_tag (FixSig _)                 = ILIT(6)
 428 sig_tag (DeprecSig _ _)            = ILIT(7)
 429 sig_tag _                          = panic# "tag(RnBinds)"
 430 \end{code}