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         ( pprHsVar )
  19 import HsPat            ( Pat )
  20 import HsTypes          ( HsType )
  21 import CoreSyn          ( CoreExpr )
  22 import PprCore          ( {- instance Outputable (Expr a) -} )
  23
  24 --others:
  25 import Name             ( Name )
  26 import PrelNames        ( isUnboundName )
  27 import NameSet          ( NameSet, elemNameSet, nameSetToList )
  28 import BasicTypes       ( RecFlag(..), FixitySig(..), Activation(..) )
  29 import Outputable
  30 import SrcLoc           ( SrcLoc )
  31 import Var              ( TyVar )
  32 import Class            ( DefMeth (..) )
  33 \end{code}
  34
  35 %************************************************************************
  36 %*                                                                      *
  37 \subsection{Bindings: @HsBinds@}
  38 %*                                                                      *
  39 %************************************************************************
  40
  41 The following syntax may produce new syntax which is not part of the input,
  42 and which is instead a translation of the input to the typechecker.
  43 Syntax translations are marked TRANSLATION in comments. New empty
  44 productions are useful in development but may not appear in the final
  45 grammar.
  46
  47 Collections of bindings, created by dependency analysis and translation:
  48
  49 \begin{code}
  50 data HsBinds id         -- binders and bindees
  51   = EmptyBinds
  52
  53   | ThenBinds   (HsBinds id)
  54                 (HsBinds id)
  55
  56   | MonoBind    (MonoBinds id)
  57                 [Sig id]                -- Empty on typechecker output, Type Signatures
  58                 RecFlag
  59 \end{code}
  60
  61 \begin{code}
  62 nullBinds :: HsBinds id -> Bool
  63
  64 nullBinds EmptyBinds            = True
  65 nullBinds (ThenBinds b1 b2)     = nullBinds b1 && nullBinds b2
  66 nullBinds (MonoBind b _ _)      = nullMonoBinds b
  67
  68 mkMonoBind :: MonoBinds id -> [Sig id] -> RecFlag -> HsBinds id
  69 mkMonoBind EmptyMonoBinds _ _ = EmptyBinds
  70 mkMonoBind mbinds sigs is_rec = MonoBind mbinds sigs is_rec
  71 \end{code}
  72
  73 \begin{code}
  74 instance (OutputableBndr id) => Outputable (HsBinds id) 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
 103   = EmptyMonoBinds
 104
 105   | AndMonoBinds    (MonoBinds id)
 106                     (MonoBinds id)
 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]
 118                     SrcLoc
 119
 120   | PatMonoBind     (Pat id)    -- The pattern is never a simple variable;
 121                                 -- That case is done by FunMonoBind
 122                     (GRHSs id)
 123                     SrcLoc
 124
 125   | VarMonoBind     id                  -- TRANSLATION
 126                     (HsExpr id)
 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)      -- 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         tp = /\ [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 -> Bool
 175 nullMonoBinds EmptyMonoBinds         = True
 176 nullMonoBinds other_monobind         = False
 177
 178 andMonoBinds :: MonoBinds id -> MonoBinds id -> MonoBinds id
 179 andMonoBinds EmptyMonoBinds mb = mb
 180 andMonoBinds mb EmptyMonoBinds = mb
 181 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
 182
 183 andMonoBindList :: [MonoBinds id] -> MonoBinds id
 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 OutputableBndr id => Outputable (MonoBinds id) where
 200     ppr mbind = ppr_monobind mbind
 201
 202
 203 ppr_monobind :: OutputableBndr id => MonoBinds id -> SDoc
 204 ppr_monobind EmptyMonoBinds = empty
 205 ppr_monobind (AndMonoBinds binds1 binds2)
 206       = ppr_monobind binds1 $$ ppr_monobind binds2
 207
 208 ppr_monobind (PatMonoBind pat grhss locn)       = pprPatBind pat grhss
 209 ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches
 210       -- ToDo: print infix if appropriate
 211
 212 ppr_monobind (VarMonoBind name expr)
 213       = sep [pprBndr LetBind name <+> equals, nest 4 (pprExpr expr)]
 214
 215 ppr_monobind (CoreMonoBind name expr)
 216       = sep [pprBndr LetBind name <+> equals, nest 4 (ppr expr)]
 217
 218 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
 219      = sep [ptext SLIT("AbsBinds"),
 220             brackets (interpp'SP tyvars),
 221             brackets (interpp'SP dictvars),
 222             brackets (sep (punctuate comma (map ppr exports))),
 223             brackets (interpp'SP (nameSetToList inlines))]
 224        $$
 225        nest 4 ( vcat [pprBndr LetBind x | (_,x,_) <- exports]
 226                         -- Print type signatures
 227                 $$
 228                 ppr val_binds )
 229 \end{code}
 230
 231 %************************************************************************
 232 %*                                                                      *
 233 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 234 %*                                                                      *
 235 %************************************************************************
 236
 237 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 238 ``specialise this function to these four types...'') in with type
 239 signatures.  Then all the machinery to move them into place, etc.,
 240 serves for both.
 241
 242 \begin{code}
 243 data Sig name
 244   = Sig         name            -- a bog-std type signature
 245                 (HsType name)
 246                 SrcLoc
 247
 248   | ClassOpSig  name            -- Selector name
 249                 (DefMeth name)  -- Default-method info
 250                                 -- See "THE NAMING STORY" in HsDecls
 251                 (HsType name)
 252                 SrcLoc
 253
 254   | SpecSig     name            -- specialise a function or datatype ...
 255                 (HsType name)   -- ... to these types
 256                 SrcLoc
 257
 258   | InlineSig   Bool            -- True <=> INLINE f, False <=> NOINLINE f
 259                 name            -- Function name
 260                 Activation      -- When inlining is *active*
 261                 SrcLoc
 262
 263   | SpecInstSig (HsType name)   -- (Class tys); should be a specialisation of the
 264                                 -- current instance decl
 265                 SrcLoc
 266
 267   | FixSig      (FixitySig name)        -- Fixity declaration
 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)         = (ptext SLIT("type signature"),loc)
 317 hsSigDoc (ClassOpSig _ _ _ loc)       = (ptext SLIT("class-method type signature"), loc)
 318 hsSigDoc (SpecSig    _ _ loc)         = (ptext SLIT("SPECIALISE pragma"),loc)
 319 hsSigDoc (InlineSig True  _ _ loc)    = (ptext SLIT("INLINE pragma"),loc)
 320 hsSigDoc (InlineSig False _ _ loc)    = (ptext SLIT("NOINLINE pragma"),loc)
 321 hsSigDoc (SpecInstSig _ loc)          = (ptext SLIT("SPECIALISE instance pragma"),loc)
 322 hsSigDoc (FixSig (FixitySig _ _ loc)) = (ptext 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       = sep [ pprHsVar var <+> dcolon,
 335               nest 4 (ppr ty),
 336               nest 4 (pp_dm_comment) ]
 337       where
 338         pp_dm = case dm of
 339                   DefMeth _  -> equals  -- Default method indicator
 340                   GenDefMeth -> semi    -- Generic method indicator
 341                   NoDefMeth  -> empty   -- No Method at all
 342         pp_dm_comment = case dm of
 343                   DefMeth _  -> text "{- has default method -}"
 344                   GenDefMeth -> text "{- has generic method -}"
 345                   NoDefMeth  -> empty   -- No Method at all
 346
 347 ppr_sig (SpecSig var ty _)
 348       = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
 349               nest 4 (ppr ty <+> text "#-}")
 350         ]
 351
 352 ppr_sig (InlineSig True var phase _)
 353       = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"]
 354
 355 ppr_sig (InlineSig False var phase _)
 356       = hsep [text "{-# NOINLINE", ppr phase, ppr var, text "#-}"]
 357
 358 ppr_sig (SpecInstSig ty _)
 359       = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
 360
 361 ppr_sig (FixSig fix_sig) = ppr fix_sig
 362 \end{code}
 363
 364 Checking for distinct signatures; oh, so boring
 365
 366
 367 \begin{code}
 368 eqHsSig :: Sig Name -> Sig Name -> Bool
 369 eqHsSig (Sig n1 _ _)         (Sig n2 _ _)          = n1 == n2
 370 eqHsSig (InlineSig b1 n1 _ _)(InlineSig b2 n2 _ _) = b1 == b2 && n1 == n2
 371
 372 eqHsSig (SpecInstSig ty1 _)  (SpecInstSig ty2 _)  = ty1 == ty2
 373 eqHsSig (SpecSig n1 ty1 _)   (SpecSig n2 ty2 _)   =
 374     -- may have many specialisations for one value;
 375     -- but not ones that are exactly the same...
 376     (n1 == n2) && (ty1 == ty2)
 377
 378 eqHsSig _other1 _other2 = False
 379 \end{code}