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   | PatMonoBind     pat
 107                     (GRHSs id pat)
 108                     SrcLoc
 109
 110   | FunMonoBind     id
 111                     Bool                -- True => infix declaration
 112                     [Match id pat]
 113                     SrcLoc
 114
 115   | VarMonoBind     id                  -- TRANSLATION
 116                     (HsExpr id pat)
 117
 118   | CoreMonoBind    id                  -- TRANSLATION
 119                     CoreExpr            -- No zonking; this is a final CoreExpr with Ids and Types!
 120
 121   | AbsBinds                            -- Binds abstraction; TRANSLATION
 122                 [TyVar]                 -- Type variables
 123                 [id]                    -- Dicts
 124                 [([TyVar], id, id)]     -- (type variables, polymorphic, momonmorphic) triples
 125                 NameSet                 -- Set of *polymorphic* variables that have an INLINE pragma
 126                 (MonoBinds id pat)      -- The "business end"
 127
 128         -- Creates bindings for *new* (polymorphic, overloaded) locals
 129         -- in terms of *old* (monomorphic, non-overloaded) ones.
 130         --
 131         -- See section 9 of static semantics paper for more details.
 132         -- (You can get a PhD for explaining the True Meaning
 133         --  of this last construct.)
 134 \end{code}
 135
 136 What AbsBinds means
 137 ~~~~~~~~~~~~~~~~~~~
 138          AbsBinds tvs
 139                   [d1,d2]
 140                   [(tvs1, f1p, f1m),
 141                    (tvs2, f2p, f2m)]
 142                   BIND
 143 means
 144
 145         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
 146                                       in fm
 147
 148         gp = ...same again, with gm instead of fm
 149
 150 This is a pretty bad translation, because it duplicates all the bindings.
 151 So the desugarer tries to do a better job:
 152
 153         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
 154                                         (fm,gm) -> fm
 155         ..ditto for gp..
 156
 157         p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
 158                                       in (fm,gm)
 159
 160 \begin{code}
 161 -- We keep the invariant that a MonoBinds is only empty
 162 -- if it is exactly EmptyMonoBinds
 163
 164 nullMonoBinds :: MonoBinds id pat -> Bool
 165 nullMonoBinds EmptyMonoBinds         = True
 166 nullMonoBinds other_monobind         = False
 167
 168 andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
 169 andMonoBinds EmptyMonoBinds mb = mb
 170 andMonoBinds mb EmptyMonoBinds = mb
 171 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
 172
 173 andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
 174 andMonoBindList binds
 175   = loop1 binds
 176   where
 177     loop1 [] = EmptyMonoBinds
 178     loop1 (EmptyMonoBinds : binds) = loop1 binds
 179     loop1 (b:bs) = loop2 b bs
 180
 181         -- acc is non-empty
 182     loop2 acc [] = acc
 183     loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
 184     loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
 185 \end{code}
 186
 187
 188 \begin{code}
 189 instance (Outputable id, Outputable pat) =>
 190                 Outputable (MonoBinds id pat) where
 191     ppr mbind = ppr_monobind mbind
 192
 193
 194 ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc
 195 ppr_monobind EmptyMonoBinds = empty
 196 ppr_monobind (AndMonoBinds binds1 binds2)
 197       = ppr_monobind binds1 $$ ppr_monobind binds2
 198
 199 ppr_monobind (PatMonoBind pat grhss locn)
 200       = sep [ppr pat, nest 4 (pprGRHSs False grhss)]
 201
 202 ppr_monobind (FunMonoBind fun inf matches locn)
 203       = pprMatches (False, ppr fun) matches
 204       -- ToDo: print infix if appropriate
 205
 206 ppr_monobind (VarMonoBind name expr)
 207       = sep [ppr name <+> equals, nest 4 (pprExpr expr)]
 208
 209 ppr_monobind (CoreMonoBind name expr)
 210       = sep [ppr name <+> equals, nest 4 (ppr expr)]
 211
 212 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
 213      = sep [ptext SLIT("AbsBinds"),
 214             brackets (interpp'SP tyvars),
 215             brackets (interpp'SP dictvars),
 216             brackets (sep (punctuate comma (map ppr exports))),
 217             brackets (interpp'SP (nameSetToList inlines))]
 218        $$
 219        nest 4 (ppr val_binds)
 220 \end{code}
 221
 222 %************************************************************************
 223 %*                                                                      *
 224 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 225 %*                                                                      *
 226 %************************************************************************
 227
 228 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 229 ``specialise this function to these four types...'') in with type
 230 signatures.  Then all the machinery to move them into place, etc.,
 231 serves for both.
 232
 233 \begin{code}
 234 data Sig name
 235   = Sig         name            -- a bog-std type signature
 236                 (HsType name)
 237                 SrcLoc
 238
 239   | ClassOpSig  name            -- Selector name
 240                 name            -- Default-method name (if any)
 241                 Bool            -- True <=> there is an explicit, programmer-supplied
 242                                 -- default declaration in the class decl
 243                 (HsType name)
 244                 SrcLoc
 245
 246   | SpecSig     name            -- specialise a function or datatype ...
 247                 (HsType name)   -- ... to these types
 248                 SrcLoc
 249
 250   | InlineSig   name            -- INLINE f
 251                 (Maybe Int)     -- phase
 252                 SrcLoc
 253
 254   | NoInlineSig name            -- NOINLINE f
 255                 (Maybe Int)     -- phase
 256                 SrcLoc
 257
 258   | SpecInstSig (HsType name)   -- (Class tys); should be a specialisation of the
 259                                 -- current instance decl
 260                 SrcLoc
 261
 262   | FixSig      (FixitySig name)        -- Fixity declaration
 263
 264   | DeprecSig   (Deprecation name)      -- DEPRECATED
 265                 SrcLoc
 266
 267 data FixitySig name  = FixitySig name Fixity SrcLoc
 268
 269 -- We use exported entities for things to deprecate. Cunning trick (hack?):
 270 -- `IEModuleContents undefined' is used for module deprecation.
 271 data Deprecation name = Deprecation (IE name) DeprecTxt
 272
 273 type DeprecTxt = FAST_STRING    -- reason/explanation for deprecation
 274 \end{code}
 275
 276 \begin{code}
 277 okBindSig :: NameSet -> Sig Name -> Bool
 278 okBindSig ns (ClassOpSig _ _ _ _ _)                             = False
 279 okBindSig ns sig = sigForThisGroup ns sig
 280
 281 okClsDclSig :: NameSet -> Sig Name -> Bool
 282 okClsDclSig ns (Sig _ _ _)                                        = False
 283 okClsDclSig ns sig = sigForThisGroup ns sig
 284
 285 okInstDclSig :: NameSet -> Sig Name -> Bool
 286 okInstDclSig ns (Sig _ _ _)                                        = False
 287 okInstDclSig ns (FixSig _)                                         = False
 288 okInstDclSig ns (SpecInstSig _ _)                                  = True
 289 okInstDclSig ns sig = sigForThisGroup ns sig
 290
 291 sigForThisGroup ns sig
 292   = case sigName sig of
 293         Nothing                  -> False
 294         Just n | isUnboundName n -> True        -- Don't complain about an unbound name again
 295                | otherwise       -> n `elemNameSet` ns
 296
 297 sigsForMe :: (name -> Bool) -> [Sig name] -> [Sig name]
 298 sigsForMe f sigs
 299   = filter sig_for_me sigs
 300   where
 301     sig_for_me sig = case sigName sig of
 302                         Nothing -> False
 303                         Just n  -> f n
 304
 305 sigName :: Sig name -> Maybe name
 306 sigName (Sig         n _ _)             = Just n
 307 sigName (ClassOpSig  n _ _ _ _)         = Just n
 308 sigName (SpecSig     n _ _)             = Just n
 309 sigName (InlineSig   n _   _)           = Just n
 310 sigName (NoInlineSig n _   _)           = Just n
 311 sigName (FixSig (FixitySig n _ _))      = Just n
 312 sigName (DeprecSig (Deprecation d _) _) = case d of
 313                                             IEModuleContents _ -> Nothing
 314                                             other              -> Just (ieName d)
 315 sigName other                           = Nothing
 316
 317 isFixitySig :: Sig name -> Bool
 318 isFixitySig (FixSig _) = True
 319 isFixitySig _          = False
 320
 321 isClassOpSig :: Sig name -> Bool
 322 isClassOpSig (ClassOpSig _ _ _ _ _) = True
 323 isClassOpSig _                      = False
 324
 325 isPragSig :: Sig name -> Bool
 326         -- Identifies pragmas
 327 isPragSig (SpecSig _ _ _)     = True
 328 isPragSig (InlineSig   _ _ _) = True
 329 isPragSig (NoInlineSig _ _ _) = True
 330 isPragSig (SpecInstSig _ _)   = True
 331 isPragSig (DeprecSig _ _)     = True
 332 isPragSig other               = False
 333 \end{code}
 334
 335 \begin{code}
 336 hsSigDoc (Sig        _ _ loc)         = (SLIT("type signature"),loc)
 337 hsSigDoc (ClassOpSig _ _ _ _ loc)     = (SLIT("class-method type signature"), loc)
 338 hsSigDoc (SpecSig    _ _ loc)         = (SLIT("SPECIALISE pragma"),loc)
 339 hsSigDoc (InlineSig  _ _    loc)      = (SLIT("INLINE pragma"),loc)
 340 hsSigDoc (NoInlineSig  _ _  loc)      = (SLIT("NOINLINE pragma"),loc)
 341 hsSigDoc (SpecInstSig _ loc)          = (SLIT("SPECIALISE instance pragma"),loc)
 342 hsSigDoc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc)
 343 hsSigDoc (DeprecSig _ loc)            = (SLIT("DEPRECATED pragma"), loc)
 344 \end{code}
 345
 346 \begin{code}
 347 instance (Outputable name) => Outputable (Sig name) where
 348     ppr sig = ppr_sig sig
 349
 350 ppr_sig :: Outputable name => Sig name -> SDoc
 351 ppr_sig (Sig var ty _)
 352       = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 353
 354 ppr_sig (ClassOpSig var _ _ ty _)
 355       = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 356
 357 ppr_sig (SpecSig var ty _)
 358       = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
 359               nest 4 (ppr ty <+> text "#-}")
 360         ]
 361
 362 ppr_sig (InlineSig var phase _)
 363       = hsep [text "{-# INLINE", ppr_phase phase, ppr var, text "#-}"]
 364
 365 ppr_sig (NoInlineSig var phase _)
 366       = hsep [text "{-# NOINLINE", ppr_phase phase, ppr var, text "#-}"]
 367
 368 ppr_sig (SpecInstSig ty _)
 369       = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
 370
 371 ppr_sig (FixSig fix_sig) = ppr fix_sig
 372
 373 ppr_sig (DeprecSig deprec _) = ppr deprec
 374
 375 instance Outputable name => Outputable (FixitySig name) where
 376   ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
 377
 378 instance Outputable name => Outputable (Deprecation name) where
 379    ppr (Deprecation (IEModuleContents _) txt)
 380       = hsep [text "{-# DEPRECATED",            doubleQuotes (ppr txt), text "#-}"]
 381    ppr (Deprecation thing txt)
 382       = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
 383
 384 ppr_phase :: Maybe Int -> SDoc
 385 ppr_phase Nothing  = empty
 386 ppr_phase (Just n) = int n
 387 \end{code}
 388
 389 Checking for distinct signatures; oh, so boring
 390
 391
 392 \begin{code}
 393 cmpHsSig :: Sig Name -> Sig Name -> Ordering
 394 cmpHsSig (Sig n1 _ _)         (Sig n2 _ _)         = n1 `compare` n2
 395 cmpHsSig (DeprecSig (Deprecation ie1 _) _)
 396          (DeprecSig (Deprecation ie2 _) _)         = cmp_ie ie1 ie2
 397 cmpHsSig (InlineSig n1 _ _)   (InlineSig n2 _ _)   = n1 `compare` n2
 398 cmpHsSig (NoInlineSig n1 _ _) (NoInlineSig n2 _ _) = n1 `compare` n2
 399
 400 cmpHsSig (SpecInstSig ty1 _)  (SpecInstSig ty2 _)  = cmpHsType compare ty1 ty2
 401 cmpHsSig (SpecSig n1 ty1 _)   (SpecSig n2 ty2 _)
 402   = -- may have many specialisations for one value;
 403     -- but not ones that are exactly the same...
 404     thenCmp (n1 `compare` n2) (cmpHsType compare ty1 ty2)
 405
 406 cmpHsSig other_1 other_2                                        -- Tags *must* be different
 407   | (sig_tag other_1) _LT_ (sig_tag other_2) = LT
 408   | otherwise                                = GT
 409
 410 cmp_ie :: IE Name -> IE Name -> Ordering
 411 cmp_ie (IEVar            n1  ) (IEVar            n2  ) = n1 `compare` n2
 412 cmp_ie (IEThingAbs       n1  ) (IEThingAbs       n2  ) = n1 `compare` n2
 413 cmp_ie (IEThingAll       n1  ) (IEThingAll       n2  ) = n1 `compare` n2
 414 -- Hmmm...
 415 cmp_ie (IEThingWith      n1 _) (IEThingWith      n2 _) = n1 `compare` n2
 416 cmp_ie (IEModuleContents _   ) (IEModuleContents _   ) = EQ
 417
 418 sig_tag (Sig n1 _ _)               = (ILIT(1) :: FAST_INT)
 419 sig_tag (SpecSig n1 _ _)           = ILIT(2)
 420 sig_tag (InlineSig n1 _ _)         = ILIT(3)
 421 sig_tag (NoInlineSig n1 _ _)       = ILIT(4)
 422 sig_tag (SpecInstSig _ _)          = ILIT(5)
 423 sig_tag (FixSig _)                 = ILIT(6)
 424 sig_tag (DeprecSig _ _)            = ILIT(7)
 425 sig_tag _                          = panic# "tag(RnBinds)"
 426 \end{code}