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   | AbsBinds                            -- Binds abstraction; TRANSLATION
 129                 [TyVar]                 -- Type variables
 130                 [id]                    -- Dicts
 131                 [([TyVar], id, id)]     -- (type variables, polymorphic, momonmorphic) triples
 132                 NameSet                 -- Set of *polymorphic* variables that have an INLINE pragma
 133                 (MonoBinds id)      -- The "business end"
 134
 135         -- Creates bindings for *new* (polymorphic, overloaded) locals
 136         -- in terms of *old* (monomorphic, non-overloaded) ones.
 137         --
 138         -- See section 9 of static semantics paper for more details.
 139         -- (You can get a PhD for explaining the True Meaning
 140         --  of this last construct.)
 141 \end{code}
 142
 143 What AbsBinds means
 144 ~~~~~~~~~~~~~~~~~~~
 145          AbsBinds tvs
 146                   [d1,d2]
 147                   [(tvs1, f1p, f1m),
 148                    (tvs2, f2p, f2m)]
 149                   BIND
 150 means
 151
 152         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
 153                                       in fm
 154
 155         gp = ...same again, with gm instead of fm
 156
 157 This is a pretty bad translation, because it duplicates all the bindings.
 158 So the desugarer tries to do a better job:
 159
 160         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
 161                                         (fm,gm) -> fm
 162         ..ditto for gp..
 163
 164         tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
 165                                        in (fm,gm)
 166
 167 \begin{code}
 168 -- We keep the invariant that a MonoBinds is only empty
 169 -- if it is exactly EmptyMonoBinds
 170
 171 nullMonoBinds :: MonoBinds id -> Bool
 172 nullMonoBinds EmptyMonoBinds         = True
 173 nullMonoBinds other_monobind         = False
 174
 175 andMonoBinds :: MonoBinds id -> MonoBinds id -> MonoBinds id
 176 andMonoBinds EmptyMonoBinds mb = mb
 177 andMonoBinds mb EmptyMonoBinds = mb
 178 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
 179
 180 andMonoBindList :: [MonoBinds id] -> MonoBinds id
 181 andMonoBindList binds
 182   = loop1 binds
 183   where
 184     loop1 [] = EmptyMonoBinds
 185     loop1 (EmptyMonoBinds : binds) = loop1 binds
 186     loop1 (b:bs) = loop2 b bs
 187
 188         -- acc is non-empty
 189     loop2 acc [] = acc
 190     loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
 191     loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
 192 \end{code}
 193
 194
 195 \begin{code}
 196 instance OutputableBndr id => Outputable (MonoBinds id) where
 197     ppr mbind = ppr_monobind mbind
 198
 199
 200 ppr_monobind :: OutputableBndr id => MonoBinds id -> 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 [pprBndr LetBind name <+> equals, nest 4 (pprExpr expr)]
 211
 212 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
 213      = sep [ptext SLIT("AbsBinds"),
 214             brackets (interpp'SP tyvars),
 215             brackets (interpp'SP dictvars),
 216             brackets (sep (punctuate comma (map ppr exports))),
 217             brackets (interpp'SP (nameSetToList inlines))]
 218        $$
 219        nest 4 ( vcat [pprBndr LetBind x | (_,x,_) <- exports]
 220                         -- Print type signatures
 221                 $$
 222                 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 \end{code}
 263
 264 \begin{code}
 265 okBindSig :: NameSet -> Sig Name -> Bool
 266 okBindSig ns (ClassOpSig _ _ _ _) = False
 267 okBindSig ns sig                  = sigForThisGroup ns sig
 268
 269 okClsDclSig :: NameSet -> Sig Name -> Bool
 270 okClsDclSig ns (Sig _ _ _) = False
 271 okClsDclSig ns sig         = sigForThisGroup ns sig
 272
 273 okInstDclSig :: NameSet -> Sig Name -> Bool
 274 okInstDclSig ns (Sig _ _ _)       = False
 275 okInstDclSig ns (FixSig _)        = False
 276 okInstDclSig ns (SpecInstSig _ _) = True
 277 okInstDclSig ns sig               = sigForThisGroup ns sig
 278
 279 sigForThisGroup ns sig
 280   = case sigName sig of
 281         Nothing                  -> False
 282         Just n | isUnboundName n -> True        -- Don't complain about an unbound name again
 283                | otherwise       -> n `elemNameSet` ns
 284
 285 sigName :: Sig name -> Maybe name
 286 sigName (Sig         n _ _)        = Just n
 287 sigName (ClassOpSig  n _ _ _)      = Just n
 288 sigName (SpecSig     n _ _)        = Just n
 289 sigName (InlineSig _ n _ _)        = Just n
 290 sigName (FixSig (FixitySig n _ _)) = Just n
 291 sigName other                      = Nothing
 292
 293 isFixitySig :: Sig name -> Bool
 294 isFixitySig (FixSig _) = True
 295 isFixitySig _          = False
 296
 297 isClassOpSig :: Sig name -> Bool
 298 isClassOpSig (ClassOpSig _ _ _ _) = True
 299 isClassOpSig _                    = False
 300
 301 isPragSig :: Sig name -> Bool
 302         -- Identifies pragmas
 303 isPragSig (SpecSig _ _ _)     = True
 304 isPragSig (InlineSig _ _ _ _) = True
 305 isPragSig (SpecInstSig _ _)   = True
 306 isPragSig other               = False
 307 \end{code}
 308
 309 \begin{code}
 310 hsSigDoc (Sig        _ _ loc)         = (ptext SLIT("type signature"),loc)
 311 hsSigDoc (ClassOpSig _ _ _ loc)       = (ptext SLIT("class-method type signature"), loc)
 312 hsSigDoc (SpecSig    _ _ loc)         = (ptext SLIT("SPECIALISE pragma"),loc)
 313 hsSigDoc (InlineSig True  _ _ loc)    = (ptext SLIT("INLINE pragma"),loc)
 314 hsSigDoc (InlineSig False _ _ loc)    = (ptext SLIT("NOINLINE pragma"),loc)
 315 hsSigDoc (SpecInstSig _ loc)          = (ptext SLIT("SPECIALISE instance pragma"),loc)
 316 hsSigDoc (FixSig (FixitySig _ _ loc)) = (ptext SLIT("fixity declaration"), loc)
 317 \end{code}
 318
 319 \begin{code}
 320 instance (Outputable name) => Outputable (Sig name) where
 321     ppr sig = ppr_sig sig
 322
 323 ppr_sig :: Outputable name => Sig name -> SDoc
 324 ppr_sig (Sig var ty _)
 325       = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 326
 327 ppr_sig (ClassOpSig var dm ty _)
 328       = sep [ pprHsVar var <+> dcolon,
 329               nest 4 (ppr ty),
 330               nest 4 (pp_dm_comment) ]
 331       where
 332         pp_dm = case dm of
 333                   DefMeth _  -> equals  -- Default method indicator
 334                   GenDefMeth -> semi    -- Generic method indicator
 335                   NoDefMeth  -> empty   -- No Method at all
 336         pp_dm_comment = case dm of
 337                   DefMeth _  -> text "{- has default method -}"
 338                   GenDefMeth -> text "{- has generic method -}"
 339                   NoDefMeth  -> empty   -- No Method at all
 340
 341 ppr_sig (SpecSig var ty _)
 342       = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
 343               nest 4 (ppr ty <+> text "#-}")
 344         ]
 345
 346 ppr_sig (InlineSig True var phase _)
 347       = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"]
 348
 349 ppr_sig (InlineSig False var phase _)
 350       = hsep [text "{-# NOINLINE", ppr phase, ppr var, text "#-}"]
 351
 352 ppr_sig (SpecInstSig ty _)
 353       = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
 354
 355 ppr_sig (FixSig fix_sig) = ppr fix_sig
 356 \end{code}
 357
 358 Checking for distinct signatures; oh, so boring
 359
 360
 361 \begin{code}
 362 eqHsSig :: Sig Name -> Sig Name -> Bool
 363 eqHsSig (Sig n1 _ _)         (Sig n2 _ _)          = n1 == n2
 364 eqHsSig (InlineSig b1 n1 _ _)(InlineSig b2 n2 _ _) = b1 == b2 && n1 == n2
 365
 366 eqHsSig (SpecInstSig ty1 _)  (SpecInstSig ty2 _)  = ty1 == ty2
 367 eqHsSig (SpecSig n1 ty1 _)   (SpecSig n2 ty2 _)   =
 368     -- may have many specialisations for one value;
 369     -- but not ones that are exactly the same...
 370     (n1 == n2) && (ty1 == ty2)
 371
 372 eqHsSig _other1 _other2 = False
 373 \end{code}