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                                 --
 113                                 -- This also means that instance decls can only have
 114                                 -- FunMonoBinds, so if you change this, you'll need to
 115                                 -- change e.g. rnMethodBinds
 116                     Bool                -- True => infix declaration
 117                     [Match id pat]
 118                     SrcLoc
 119
 120   | PatMonoBind     pat         -- The pattern is never a simple variable;
 121                                 -- That case is done by FunMonoBind
 122                     (GRHSs id pat)
 123                     SrcLoc
 124
 125   | VarMonoBind     id                  -- TRANSLATION
 126                     (HsExpr id pat)
 127
 128   | CoreMonoBind    id                  -- TRANSLATION
 129                     CoreExpr            -- No zonking; this is a final CoreExpr with Ids and Types!
 130
 131   | AbsBinds                            -- Binds abstraction; TRANSLATION
 132                 [TyVar]                 -- Type variables
 133                 [id]                    -- Dicts
 134                 [([TyVar], id, id)]     -- (type variables, polymorphic, momonmorphic) triples
 135                 NameSet                 -- Set of *polymorphic* variables that have an INLINE pragma
 136                 (MonoBinds id pat)      -- The "business end"
 137
 138         -- Creates bindings for *new* (polymorphic, overloaded) locals
 139         -- in terms of *old* (monomorphic, non-overloaded) ones.
 140         --
 141         -- See section 9 of static semantics paper for more details.
 142         -- (You can get a PhD for explaining the True Meaning
 143         --  of this last construct.)
 144 \end{code}
 145
 146 What AbsBinds means
 147 ~~~~~~~~~~~~~~~~~~~
 148          AbsBinds tvs
 149                   [d1,d2]
 150                   [(tvs1, f1p, f1m),
 151                    (tvs2, f2p, f2m)]
 152                   BIND
 153 means
 154
 155         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
 156                                       in fm
 157
 158         gp = ...same again, with gm instead of fm
 159
 160 This is a pretty bad translation, because it duplicates all the bindings.
 161 So the desugarer tries to do a better job:
 162
 163         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
 164                                         (fm,gm) -> fm
 165         ..ditto for gp..
 166
 167         p = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
 168                                       in (fm,gm)
 169
 170 \begin{code}
 171 -- We keep the invariant that a MonoBinds is only empty
 172 -- if it is exactly EmptyMonoBinds
 173
 174 nullMonoBinds :: MonoBinds id pat -> Bool
 175 nullMonoBinds EmptyMonoBinds         = True
 176 nullMonoBinds other_monobind         = False
 177
 178 andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
 179 andMonoBinds EmptyMonoBinds mb = mb
 180 andMonoBinds mb EmptyMonoBinds = mb
 181 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
 182
 183 andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
 184 andMonoBindList binds
 185   = loop1 binds
 186   where
 187     loop1 [] = EmptyMonoBinds
 188     loop1 (EmptyMonoBinds : binds) = loop1 binds
 189     loop1 (b:bs) = loop2 b bs
 190
 191         -- acc is non-empty
 192     loop2 acc [] = acc
 193     loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
 194     loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
 195 \end{code}
 196
 197
 198 \begin{code}
 199 instance (Outputable id, Outputable pat) =>
 200                 Outputable (MonoBinds id pat) where
 201     ppr mbind = ppr_monobind mbind
 202
 203
 204 ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc
 205 ppr_monobind EmptyMonoBinds = empty
 206 ppr_monobind (AndMonoBinds binds1 binds2)
 207       = ppr_monobind binds1 $$ ppr_monobind binds2
 208
 209 ppr_monobind (PatMonoBind pat grhss locn)       = pprPatBind pat grhss
 210 ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches
 211       -- ToDo: print infix if appropriate
 212
 213 ppr_monobind (VarMonoBind name expr)
 214       = sep [ppr name <+> equals, nest 4 (pprExpr expr)]
 215
 216 ppr_monobind (CoreMonoBind name expr)
 217       = sep [ppr name <+> equals, nest 4 (ppr expr)]
 218
 219 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
 220      = sep [ptext SLIT("AbsBinds"),
 221             brackets (interpp'SP tyvars),
 222             brackets (interpp'SP dictvars),
 223             brackets (sep (punctuate comma (map ppr exports))),
 224             brackets (interpp'SP (nameSetToList inlines))]
 225        $$
 226        nest 4 (ppr val_binds)
 227 \end{code}
 228
 229 %************************************************************************
 230 %*                                                                      *
 231 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 232 %*                                                                      *
 233 %************************************************************************
 234
 235 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 236 ``specialise this function to these four types...'') in with type
 237 signatures.  Then all the machinery to move them into place, etc.,
 238 serves for both.
 239
 240 \begin{code}
 241 data Sig name
 242   = Sig         name            -- a bog-std type signature
 243                 (HsType name)
 244                 SrcLoc
 245
 246   | ClassOpSig  name            -- Selector name
 247                 (DefMeth name)  -- Default-method info
 248                                 -- See "THE NAMING STORY" in HsDecls
 249                 (HsType name)
 250                 SrcLoc
 251
 252   | SpecSig     name            -- specialise a function or datatype ...
 253                 (HsType name)   -- ... to these types
 254                 SrcLoc
 255
 256   | InlineSig   Bool            -- True <=> INLINE f, False <=> NOINLINE f
 257                 name            -- Function name
 258                 Activation      -- When inlining is *active*
 259                 SrcLoc
 260
 261   | SpecInstSig (HsType name)   -- (Class tys); should be a specialisation of the
 262                                 -- current instance decl
 263                 SrcLoc
 264
 265   | FixSig      (FixitySig name)        -- Fixity declaration
 266
 267
 268 data FixitySig name = FixitySig name Fixity SrcLoc
 269
 270 instance Eq name => Eq (FixitySig name) where
 271    (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2
 272 \end{code}
 273
 274 \begin{code}
 275 okBindSig :: NameSet -> Sig Name -> Bool
 276 okBindSig ns (ClassOpSig _ _ _ _)                               = False
 277 okBindSig ns sig = sigForThisGroup ns sig
 278
 279 okClsDclSig :: NameSet -> Sig Name -> Bool
 280 okClsDclSig ns (Sig _ _ _)                                        = False
 281 okClsDclSig ns sig = sigForThisGroup ns sig
 282
 283 okInstDclSig :: NameSet -> Sig Name -> Bool
 284 okInstDclSig ns (Sig _ _ _)                                        = False
 285 okInstDclSig ns (FixSig _)                                         = False
 286 okInstDclSig ns (SpecInstSig _ _)                                  = True
 287 okInstDclSig ns sig = sigForThisGroup ns sig
 288
 289 sigForThisGroup ns sig
 290   = case sigName sig of
 291         Nothing                  -> False
 292         Just n | isUnboundName n -> True        -- Don't complain about an unbound name again
 293                | otherwise       -> n `elemNameSet` ns
 294
 295 sigName :: Sig name -> Maybe name
 296 sigName (Sig         n _ _)        = Just n
 297 sigName (ClassOpSig  n _ _ _)      = Just n
 298 sigName (SpecSig     n _ _)        = Just n
 299 sigName (InlineSig _ n _ _)        = Just n
 300 sigName (FixSig (FixitySig n _ _)) = Just n
 301 sigName other                      = Nothing
 302
 303 isFixitySig :: Sig name -> Bool
 304 isFixitySig (FixSig _) = True
 305 isFixitySig _          = False
 306
 307 isClassOpSig :: Sig name -> Bool
 308 isClassOpSig (ClassOpSig _ _ _ _) = True
 309 isClassOpSig _                    = False
 310
 311 isPragSig :: Sig name -> Bool
 312         -- Identifies pragmas
 313 isPragSig (SpecSig _ _ _)     = True
 314 isPragSig (InlineSig _ _ _ _) = 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 True  _ _ loc)    = (SLIT("INLINE pragma"),loc)
 324 hsSigDoc (InlineSig False _ _ 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       = getPprStyle $ \ sty ->
 339         if ifaceStyle sty
 340            then sep [ ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty) ]
 341            else sep [ ppr_var var <+> dcolon,
 342                       nest 4 (ppr ty),
 343                       nest 4 (pp_dm_comment) ]
 344       where
 345         pp_dm = case dm of
 346                   DefMeth _  -> equals  -- Default method indicator
 347                   GenDefMeth -> semi    -- Generic method indicator
 348                   NoDefMeth  -> empty   -- No Method at all
 349         pp_dm_comment = case dm of
 350                   DefMeth _  -> text "{- has default method -}"
 351                   GenDefMeth -> text "{- has generic method -}"
 352                   NoDefMeth  -> empty   -- No Method at all
 353
 354 ppr_sig (SpecSig var ty _)
 355       = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
 356               nest 4 (ppr ty <+> text "#-}")
 357         ]
 358
 359 ppr_sig (InlineSig True var phase _)
 360       = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"]
 361
 362 ppr_sig (InlineSig False var phase _)
 363       = hsep [text "{-# NOINLINE", pp_phase phase, ppr var, text "#-}"]
 364       where
 365         pp_phase NeverActive     = empty                -- NOINLINE f
 366         pp_phase (ActiveAfter n) = pprPhase n           -- NOINLINE [2] f
 367         pp_phase AlwaysActive    = text "ALWAYS?"       -- Unexpected
 368
 369 ppr_sig (SpecInstSig ty _)
 370       = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
 371
 372 ppr_sig (FixSig fix_sig) = ppr fix_sig
 373
 374
 375 instance Outputable name => Outputable (FixitySig name) where
 376   ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
 377 \end{code}
 378
 379 Checking for distinct signatures; oh, so boring
 380
 381
 382 \begin{code}
 383 eqHsSig :: Sig Name -> Sig Name -> Bool
 384 eqHsSig (Sig n1 _ _)         (Sig n2 _ _)          = n1 == n2
 385 eqHsSig (InlineSig b1 n1 _ _)(InlineSig b2 n2 _ _) = b1 == b2 && n1 == n2
 386
 387 eqHsSig (SpecInstSig ty1 _)  (SpecInstSig ty2 _)  = ty1 == ty2
 388 eqHsSig (SpecSig n1 ty1 _)   (SpecSig n2 ty2 _)   =
 389     -- may have many specialisations for one value;
 390     -- but not ones that are exactly the same...
 391     (n1 == n2) && (ty1 == ty2)
 392
 393 eqHsSig _other1 _other2 = False
 394 \end{code}