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 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(..), FixitySig(..), Activation(..), IPName )
  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         -- binders and bindees
  50   = EmptyBinds
  51   | ThenBinds   (HsBinds id) (HsBinds id)
  52
  53   | MonoBind                    -- A mutually recursive group
  54         (MonoBinds id)
  55         [Sig id]                -- Empty on typechecker output, Type Signatures
  56         RecFlag
  57
  58   | IPBinds                     -- Implcit parameters
  59                                 -- Not allowed at top level
  60         [(IPName id, HsExpr id)]
  61 \end{code}
  62
  63 \begin{code}
  64 nullBinds :: HsBinds id -> Bool
  65
  66 nullBinds EmptyBinds            = True
  67 nullBinds (ThenBinds b1 b2)     = nullBinds b1 && nullBinds b2
  68 nullBinds (MonoBind b _ _)      = nullMonoBinds b
  69 nullBinds (IPBinds b)           = null b
  70
  71 mkMonoBind :: RecFlag -> MonoBinds id -> HsBinds id
  72 mkMonoBind _      EmptyMonoBinds  = EmptyBinds
  73 mkMonoBind is_rec mbinds          = MonoBind mbinds [] is_rec
  74 \end{code}
  75
  76 \begin{code}
  77 instance (OutputableBndr id) => Outputable (HsBinds id) where
  78     ppr binds = ppr_binds binds
  79
  80 ppr_binds EmptyBinds = empty
  81 ppr_binds (ThenBinds binds1 binds2)
  82     = ppr_binds binds1 $$ ppr_binds binds2
  83
  84 ppr_binds (IPBinds binds)
  85   = sep (punctuate semi (map pp_item binds))
  86   where
  87     pp_item (id,rhs) = pprBndr LetBind id <+> equals <+> pprExpr rhs
  88
  89 ppr_binds (MonoBind bind sigs is_rec)
  90      = vcat [ppr_isrec,
  91              vcat (map ppr sigs),
  92              ppr bind
  93        ]
  94      where
  95        ppr_isrec = getPprStyle $ \ sty ->
  96                    if userStyle sty then empty else
  97                    case is_rec of
  98                         Recursive    -> ptext SLIT("{- rec -}")
  99                         NonRecursive -> ptext SLIT("{- nonrec -}")
 100 \end{code}
 101
 102 %************************************************************************
 103 %*                                                                      *
 104 \subsection{Bindings: @MonoBinds@}
 105 %*                                                                      *
 106 %************************************************************************
 107
 108 Global bindings (where clauses)
 109
 110 \begin{code}
 111 data MonoBinds id
 112   = EmptyMonoBinds
 113
 114   | AndMonoBinds    (MonoBinds id)
 115                     (MonoBinds id)
 116
 117   | FunMonoBind     id          -- Used for both functions      f x = e
 118                                 -- and variables                f = \x -> e
 119                                 -- Reason: the Match stuff lets us have an optional
 120                                 --         result type sig      f :: a->a = ...mentions a...
 121                                 --
 122                                 -- This also means that instance decls can only have
 123                                 -- FunMonoBinds, so if you change this, you'll need to
 124                                 -- change e.g. rnMethodBinds
 125                     Bool                -- True => infix declaration
 126                     [Match id]
 127                     SrcLoc
 128
 129   | PatMonoBind     (Pat id)    -- The pattern is never a simple variable;
 130                                 -- That case is done by FunMonoBind
 131                     (GRHSs id)
 132                     SrcLoc
 133
 134   | VarMonoBind     id                  -- TRANSLATION
 135                     (HsExpr id)
 136
 137   | AbsBinds                            -- Binds abstraction; TRANSLATION
 138                 [TyVar]                 -- Type variables
 139                 [id]                    -- Dicts
 140                 [([TyVar], id, id)]     -- (type variables, polymorphic, momonmorphic) triples
 141                 NameSet                 -- Set of *polymorphic* variables that have an INLINE pragma
 142                 (MonoBinds id)      -- The "business end"
 143
 144         -- Creates bindings for *new* (polymorphic, overloaded) locals
 145         -- in terms of *old* (monomorphic, non-overloaded) ones.
 146         --
 147         -- See section 9 of static semantics paper for more details.
 148         -- (You can get a PhD for explaining the True Meaning
 149         --  of this last construct.)
 150 \end{code}
 151
 152 What AbsBinds means
 153 ~~~~~~~~~~~~~~~~~~~
 154          AbsBinds tvs
 155                   [d1,d2]
 156                   [(tvs1, f1p, f1m),
 157                    (tvs2, f2p, f2m)]
 158                   BIND
 159 means
 160
 161         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
 162                                       in fm
 163
 164         gp = ...same again, with gm instead of fm
 165
 166 This is a pretty bad translation, because it duplicates all the bindings.
 167 So the desugarer tries to do a better job:
 168
 169         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
 170                                         (fm,gm) -> fm
 171         ..ditto for gp..
 172
 173         tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
 174                                        in (fm,gm)
 175
 176 \begin{code}
 177 -- We keep the invariant that a MonoBinds is only empty
 178 -- if it is exactly EmptyMonoBinds
 179
 180 nullMonoBinds :: MonoBinds id -> Bool
 181 nullMonoBinds EmptyMonoBinds         = True
 182 nullMonoBinds other_monobind         = False
 183
 184 andMonoBinds :: MonoBinds id -> MonoBinds id -> MonoBinds id
 185 andMonoBinds EmptyMonoBinds mb = mb
 186 andMonoBinds mb EmptyMonoBinds = mb
 187 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
 188
 189 andMonoBindList :: [MonoBinds id] -> MonoBinds id
 190 andMonoBindList binds
 191   = loop1 binds
 192   where
 193     loop1 [] = EmptyMonoBinds
 194     loop1 (EmptyMonoBinds : binds) = loop1 binds
 195     loop1 (b:bs) = loop2 b bs
 196
 197         -- acc is non-empty
 198     loop2 acc [] = acc
 199     loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
 200     loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
 201 \end{code}
 202
 203
 204 \begin{code}
 205 instance OutputableBndr id => Outputable (MonoBinds id) where
 206     ppr mbind = ppr_monobind mbind
 207
 208
 209 ppr_monobind :: OutputableBndr id => MonoBinds id -> SDoc
 210 ppr_monobind EmptyMonoBinds = empty
 211 ppr_monobind (AndMonoBinds binds1 binds2)
 212       = ppr_monobind binds1 $$ ppr_monobind binds2
 213
 214 ppr_monobind (PatMonoBind pat grhss locn)       = pprPatBind pat grhss
 215 ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches
 216       -- ToDo: print infix if appropriate
 217
 218 ppr_monobind (VarMonoBind name expr)
 219       = sep [pprBndr LetBind name <+> equals, nest 4 (pprExpr expr)]
 220
 221 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
 222      = sep [ptext SLIT("AbsBinds"),
 223             brackets (interpp'SP tyvars),
 224             brackets (interpp'SP dictvars),
 225             brackets (sep (punctuate comma (map ppr exports))),
 226             brackets (interpp'SP (nameSetToList inlines))]
 227        $$
 228        nest 4 ( vcat [pprBndr LetBind x | (_,x,_) <- exports]
 229                         -- Print type signatures
 230                 $$
 231                 ppr val_binds )
 232 \end{code}
 233
 234 %************************************************************************
 235 %*                                                                      *
 236 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 237 %*                                                                      *
 238 %************************************************************************
 239
 240 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 241 ``specialise this function to these four types...'') in with type
 242 signatures.  Then all the machinery to move them into place, etc.,
 243 serves for both.
 244
 245 \begin{code}
 246 data Sig name
 247   = Sig         name            -- a bog-std type signature
 248                 (HsType name)
 249                 SrcLoc
 250
 251   | ClassOpSig  name            -- Selector name
 252                 (DefMeth name)  -- Default-method info
 253                                 -- See "THE NAMING STORY" in HsDecls
 254                 (HsType name)
 255                 SrcLoc
 256
 257   | SpecSig     name            -- specialise a function or datatype ...
 258                 (HsType name)   -- ... to these types
 259                 SrcLoc
 260
 261   | InlineSig   Bool            -- True <=> INLINE f, False <=> NOINLINE f
 262                 name            -- Function name
 263                 Activation      -- When inlining is *active*
 264                 SrcLoc
 265
 266   | SpecInstSig (HsType name)   -- (Class tys); should be a specialisation of the
 267                                 -- current instance decl
 268                 SrcLoc
 269
 270   | FixSig      (FixitySig name)        -- Fixity declaration
 271 \end{code}
 272
 273 \begin{code}
 274 okBindSig :: NameSet -> Sig Name -> Bool
 275 okBindSig ns (ClassOpSig _ _ _ _) = False
 276 okBindSig ns sig                  = sigForThisGroup ns sig
 277
 278 okClsDclSig :: Sig Name -> Bool
 279 okClsDclSig (Sig _ _ _)       = False
 280 okClsDclSig (SpecInstSig _ _) = False
 281 okClsDclSig sig               = True    -- All others OK
 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)         = (ptext SLIT("type signature"),loc)
 321 hsSigDoc (ClassOpSig _ _ _ loc)       = (ptext SLIT("class-method type signature"), loc)
 322 hsSigDoc (SpecSig    _ _ loc)         = (ptext SLIT("SPECIALISE pragma"),loc)
 323 hsSigDoc (InlineSig True  _ _ loc)    = (ptext SLIT("INLINE pragma"),loc)
 324 hsSigDoc (InlineSig False _ _ loc)    = (ptext SLIT("NOINLINE pragma"),loc)
 325 hsSigDoc (SpecInstSig _ loc)          = (ptext SLIT("SPECIALISE instance pragma"),loc)
 326 hsSigDoc (FixSig (FixitySig _ _ loc)) = (ptext 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       = sep [ pprHsVar var <+> dcolon,
 339               nest 4 (ppr ty),
 340               nest 4 (pp_dm_comment) ]
 341       where
 342         pp_dm = case dm of
 343                   DefMeth _  -> equals  -- Default method indicator
 344                   GenDefMeth -> semi    -- Generic method indicator
 345                   NoDefMeth  -> empty   -- No Method at all
 346         pp_dm_comment = case dm of
 347                   DefMeth _  -> text "{- has default method -}"
 348                   GenDefMeth -> text "{- has generic method -}"
 349                   NoDefMeth  -> empty   -- No Method at all
 350
 351 ppr_sig (SpecSig var ty _)
 352       = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
 353               nest 4 (ppr ty <+> text "#-}")
 354         ]
 355
 356 ppr_sig (InlineSig True var phase _)
 357       = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"]
 358
 359 ppr_sig (InlineSig False var phase _)
 360       = hsep [text "{-# NOINLINE", ppr phase, ppr var, text "#-}"]
 361
 362 ppr_sig (SpecInstSig ty _)
 363       = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
 364
 365 ppr_sig (FixSig fix_sig) = ppr fix_sig
 366 \end{code}
 367
 368 Checking for distinct signatures; oh, so boring
 369
 370
 371 \begin{code}
 372 eqHsSig :: Sig Name -> Sig Name -> Bool
 373 eqHsSig (Sig n1 _ _)         (Sig n2 _ _)          = n1 == n2
 374 eqHsSig (InlineSig b1 n1 _ _)(InlineSig b2 n2 _ _) = b1 == b2 && n1 == n2
 375
 376 eqHsSig (SpecInstSig ty1 _)  (SpecInstSig ty2 _)  = ty1 == ty2
 377 eqHsSig (SpecSig n1 ty1 _)   (SpecSig n2 ty2 _)   =
 378     -- may have many specialisations for one value;
 379     -- but not ones that are exactly the same...
 380     (n1 == n2) && (ty1 == ty2)
 381
 382 eqHsSig _other1 _other2 = False
 383 \end{code}