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 ( HsExpr, pprExpr,
  14                                Match,  pprFunBind,
  15                                GRHSs,  pprPatBind )
  16
  17 -- friends:
  18 import HsImpExp         ( ppr_var )
  19 import HsTypes          ( HsType )
  20 import CoreSyn          ( CoreExpr )
  21 import PprCore          ( {- instance Outputable (Expr a) -} )
  22
  23 --others:
  24 import Name             ( Name )
  25 import PrelNames        ( isUnboundName )
  26 import NameSet          ( NameSet, elemNameSet, nameSetToList )
  27 import BasicTypes       ( RecFlag(..), Fixity, Activation(..), pprPhase )
  28 import Outputable
  29 import SrcLoc           ( SrcLoc )
  30 import Var              ( TyVar )
  31 import Class            ( DefMeth (..) )
  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 [ppr_isrec,
  82              vcat (map ppr sigs),
  83              ppr bind
  84        ]
  85      where
  86        ppr_isrec = getPprStyle $ \ sty ->
  87                    if userStyle sty then empty else
  88                    case is_rec of
  89                         Recursive    -> ptext SLIT("{- rec -}")
  90                         NonRecursive -> ptext SLIT("{- nonrec -}")
  91 \end{code}
  92
  93 %************************************************************************
  94 %*                                                                      *
  95 \subsection{Bindings: @MonoBinds@}
  96 %*                                                                      *
  97 %************************************************************************
  98
  99 Global bindings (where clauses)
 100
 101 \begin{code}
 102 data MonoBinds id pat
 103   = EmptyMonoBinds
 104
 105   | AndMonoBinds    (MonoBinds id pat)
 106                     (MonoBinds id pat)
 107
 108   | FunMonoBind     id          -- Used for both functions      f x = e
 109                                 -- and variables                f = \x -> e
 110                                 -- Reason: the Match stuff lets us have an optional
 111                                 --         result type sig      f :: a->a = ...mentions a...
 112                     Bool                -- True => infix declaration
 113                     [Match id pat]
 114                     SrcLoc
 115
 116   | PatMonoBind     pat         -- The pattern is never a simple variable;
 117                                 -- That case is done by FunMonoBind
 118                     (GRHSs id pat)
 119                     SrcLoc
 120
 121   | VarMonoBind     id                  -- TRANSLATION
 122                     (HsExpr id pat)
 123
 124   | CoreMonoBind    id                  -- TRANSLATION
 125                     CoreExpr            -- No zonking; this is a final CoreExpr with Ids and Types!
 126
 127   | AbsBinds                            -- Binds abstraction; TRANSLATION
 128                 [TyVar]                 -- Type variables
 129                 [id]                    -- Dicts
 130                 [([TyVar], id, id)]     -- (type variables, polymorphic, momonmorphic) triples
 131                 NameSet                 -- Set of *polymorphic* variables that have an INLINE pragma
 132                 (MonoBinds id pat)      -- The "business end"
 133
 134         -- Creates bindings for *new* (polymorphic, overloaded) locals
 135         -- in terms of *old* (monomorphic, non-overloaded) ones.
 136         --
 137         -- See section 9 of static semantics paper for more details.
 138         -- (You can get a PhD for explaining the True Meaning
 139         --  of this last construct.)
 140 \end{code}
 141
 142 What AbsBinds means
 143 ~~~~~~~~~~~~~~~~~~~
 144          AbsBinds tvs
 145                   [d1,d2]
 146                   [(tvs1, f1p, f1m),
 147                    (tvs2, f2p, f2m)]
 148                   BIND
 149 means
 150
 151         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
 152                                       in fm
 153
 154         gp = ...same again, with gm instead of fm
 155
 156 This is a pretty bad translation, because it duplicates all the bindings.
 157 So the desugarer tries to do a better job:
 158
 159         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
 160                                         (fm,gm) -> fm
 161         ..ditto for gp..
 162
 163         p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
 164                                       in (fm,gm)
 165
 166 \begin{code}
 167 -- We keep the invariant that a MonoBinds is only empty
 168 -- if it is exactly EmptyMonoBinds
 169
 170 nullMonoBinds :: MonoBinds id pat -> Bool
 171 nullMonoBinds EmptyMonoBinds         = True
 172 nullMonoBinds other_monobind         = False
 173
 174 andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
 175 andMonoBinds EmptyMonoBinds mb = mb
 176 andMonoBinds mb EmptyMonoBinds = mb
 177 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
 178
 179 andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
 180 andMonoBindList binds
 181   = loop1 binds
 182   where
 183     loop1 [] = EmptyMonoBinds
 184     loop1 (EmptyMonoBinds : binds) = loop1 binds
 185     loop1 (b:bs) = loop2 b bs
 186
 187         -- acc is non-empty
 188     loop2 acc [] = acc
 189     loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
 190     loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
 191 \end{code}
 192
 193
 194 \begin{code}
 195 instance (Outputable id, Outputable pat) =>
 196                 Outputable (MonoBinds id pat) where
 197     ppr mbind = ppr_monobind mbind
 198
 199
 200 ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc
 201 ppr_monobind EmptyMonoBinds = empty
 202 ppr_monobind (AndMonoBinds binds1 binds2)
 203       = ppr_monobind binds1 $$ ppr_monobind binds2
 204
 205 ppr_monobind (PatMonoBind pat grhss locn)       = pprPatBind pat grhss
 206 ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind 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   Bool            -- True <=> INLINE f, False <=> NOINLINE f
 253                 name            -- Function name
 254                 Activation      -- When inlining is *active*
 255                 SrcLoc
 256
 257   | SpecInstSig (HsType name)   -- (Class tys); should be a specialisation of the
 258                                 -- current instance decl
 259                 SrcLoc
 260
 261   | FixSig      (FixitySig name)        -- Fixity declaration
 262
 263
 264 data FixitySig name = FixitySig name Fixity SrcLoc
 265
 266 instance Eq name => Eq (FixitySig name) where
 267    (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2
 268 \end{code}
 269
 270 \begin{code}
 271 okBindSig :: NameSet -> Sig Name -> Bool
 272 okBindSig ns (ClassOpSig _ _ _ _)                               = False
 273 okBindSig ns sig = sigForThisGroup ns sig
 274
 275 okClsDclSig :: NameSet -> Sig Name -> Bool
 276 okClsDclSig ns (Sig _ _ _)                                        = False
 277 okClsDclSig ns sig = sigForThisGroup ns sig
 278
 279 okInstDclSig :: NameSet -> Sig Name -> Bool
 280 okInstDclSig ns (Sig _ _ _)                                        = False
 281 okInstDclSig ns (FixSig _)                                         = False
 282 okInstDclSig ns (SpecInstSig _ _)                                  = True
 283 okInstDclSig ns sig = sigForThisGroup ns sig
 284
 285 sigForThisGroup ns sig
 286   = case sigName sig of
 287         Nothing                  -> False
 288         Just n | isUnboundName n -> True        -- Don't complain about an unbound name again
 289                | otherwise       -> n `elemNameSet` ns
 290
 291 sigName :: Sig name -> Maybe name
 292 sigName (Sig         n _ _)        = Just n
 293 sigName (ClassOpSig  n _ _ _)      = Just n
 294 sigName (SpecSig     n _ _)        = Just n
 295 sigName (InlineSig _ n _ _)        = Just n
 296 sigName (FixSig (FixitySig n _ _)) = Just n
 297 sigName other                      = Nothing
 298
 299 isFixitySig :: Sig name -> Bool
 300 isFixitySig (FixSig _) = True
 301 isFixitySig _          = False
 302
 303 isClassOpSig :: Sig name -> Bool
 304 isClassOpSig (ClassOpSig _ _ _ _) = True
 305 isClassOpSig _                    = False
 306
 307 isPragSig :: Sig name -> Bool
 308         -- Identifies pragmas
 309 isPragSig (SpecSig _ _ _)     = True
 310 isPragSig (InlineSig _ _ _ _) = True
 311 isPragSig (SpecInstSig _ _)   = True
 312 isPragSig other               = False
 313 \end{code}
 314
 315 \begin{code}
 316 hsSigDoc (Sig        _ _ loc)         = (SLIT("type signature"),loc)
 317 hsSigDoc (ClassOpSig _ _ _ loc)       = (SLIT("class-method type signature"), loc)
 318 hsSigDoc (SpecSig    _ _ loc)         = (SLIT("SPECIALISE pragma"),loc)
 319 hsSigDoc (InlineSig True  _ _ loc)    = (SLIT("INLINE pragma"),loc)
 320 hsSigDoc (InlineSig False _ _ loc)    = (SLIT("NOINLINE pragma"),loc)
 321 hsSigDoc (SpecInstSig _ loc)          = (SLIT("SPECIALISE instance pragma"),loc)
 322 hsSigDoc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc)
 323 \end{code}
 324
 325 \begin{code}
 326 instance (Outputable name) => Outputable (Sig name) where
 327     ppr sig = ppr_sig sig
 328
 329 ppr_sig :: Outputable name => Sig name -> SDoc
 330 ppr_sig (Sig var ty _)
 331       = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 332
 333 ppr_sig (ClassOpSig var dm ty _)
 334       = getPprStyle $ \ sty ->
 335         if ifaceStyle sty
 336            then sep [ ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty) ]
 337            else sep [ ppr_var var <+> dcolon,
 338                       nest 4 (ppr ty),
 339                       nest 4 (pp_dm_comment) ]
 340       where
 341         pp_dm = case dm of
 342                   DefMeth _  -> equals  -- Default method indicator
 343                   GenDefMeth -> semi    -- Generic method indicator
 344                   NoDefMeth  -> empty   -- No Method at all
 345         pp_dm_comment = case dm of
 346                   DefMeth _  -> text "{- has default method -}"
 347                   GenDefMeth -> text "{- has generic method -}"
 348                   NoDefMeth  -> empty   -- No Method at all
 349
 350 ppr_sig (SpecSig var ty _)
 351       = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
 352               nest 4 (ppr ty <+> text "#-}")
 353         ]
 354
 355 ppr_sig (InlineSig True var phase _)
 356       = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"]
 357
 358 ppr_sig (InlineSig False var phase _)
 359       = hsep [text "{-# NOINLINE", pp_phase phase, ppr var, text "#-}"]
 360       where
 361         pp_phase NeverActive     = empty                -- NOINLINE f
 362         pp_phase (ActiveAfter n) = pprPhase n           -- NOINLINE [2] f
 363         pp_phase AlwaysActive    = text "ALWAYS?"       -- Unexpected
 364
 365 ppr_sig (SpecInstSig ty _)
 366       = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
 367
 368 ppr_sig (FixSig fix_sig) = ppr fix_sig
 369
 370
 371 instance Outputable name => Outputable (FixitySig name) where
 372   ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
 373 \end{code}
 374
 375 Checking for distinct signatures; oh, so boring
 376
 377
 378 \begin{code}
 379 eqHsSig :: Sig Name -> Sig Name -> Bool
 380 eqHsSig (Sig n1 _ _)         (Sig n2 _ _)          = n1 == n2
 381 eqHsSig (InlineSig b1 n1 _ _)(InlineSig b2 n2 _ _) = b1 == b2 && n1 == n2
 382
 383 eqHsSig (SpecInstSig ty1 _)  (SpecInstSig ty2 _)  = ty1 == ty2
 384 eqHsSig (SpecSig n1 ty1 _)   (SpecSig n2 ty2 _)   =
 385     -- may have many specialisations for one value;
 386     -- but not ones that are exactly the same...
 387     (n1 == n2) && (ty1 == ty2)
 388
 389 eqHsSig _other1 _other2 = False
 390 \end{code}