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