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