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 HsPat            ( Pat )
  19 import HsTypes          ( HsType )
  20
  21 --others:
  22 import Name             ( Name )
  23 import NameSet          ( NameSet, elemNameSet, nameSetToList )
  24 import BasicTypes       ( RecFlag(..), Activation(..), Fixity, IPName )
  25 import Outputable
  26 import SrcLoc           ( SrcLoc )
  27 import Var              ( TyVar )
  28 \end{code}
  29
  30 %************************************************************************
  31 %*                                                                      *
  32 \subsection{Bindings: @HsBinds@}
  33 %*                                                                      *
  34 %************************************************************************
  35
  36 The following syntax may produce new syntax which is not part of the input,
  37 and which is instead a translation of the input to the typechecker.
  38 Syntax translations are marked TRANSLATION in comments. New empty
  39 productions are useful in development but may not appear in the final
  40 grammar.
  41
  42 Collections of bindings, created by dependency analysis and translation:
  43
  44 \begin{code}
  45 data HsBinds id         -- binders and bindees
  46   = EmptyBinds
  47   | ThenBinds   (HsBinds id) (HsBinds id)
  48
  49   | MonoBind                    -- A mutually recursive group
  50         (MonoBinds id)
  51         [Sig id]                -- Empty on typechecker output, Type Signatures
  52         RecFlag
  53
  54   | IPBinds                     -- Implcit parameters
  55                                 -- Not allowed at top level
  56         [(IPName id, HsExpr id)]
  57 \end{code}
  58
  59 \begin{code}
  60 nullBinds :: HsBinds id -> Bool
  61
  62 nullBinds EmptyBinds            = True
  63 nullBinds (ThenBinds b1 b2)     = nullBinds b1 && nullBinds b2
  64 nullBinds (MonoBind b _ _)      = nullMonoBinds b
  65 nullBinds (IPBinds b)           = null b
  66
  67 mkMonoBind :: RecFlag -> MonoBinds id -> HsBinds id
  68 mkMonoBind _      EmptyMonoBinds  = EmptyBinds
  69 mkMonoBind is_rec mbinds          = MonoBind mbinds [] is_rec
  70 \end{code}
  71
  72 \begin{code}
  73 instance (OutputableBndr id) => Outputable (HsBinds id) where
  74     ppr binds = ppr_binds binds
  75
  76 ppr_binds EmptyBinds = empty
  77 ppr_binds (ThenBinds binds1 binds2)
  78     = ppr_binds binds1 $$ ppr_binds binds2
  79
  80 ppr_binds (IPBinds binds)
  81   = sep (punctuate semi (map pp_item binds))
  82   where
  83     pp_item (id,rhs) = pprBndr LetBind id <+> equals <+> pprExpr rhs
  84
  85 ppr_binds (MonoBind bind sigs is_rec)
  86      = vcat [ppr_isrec,
  87              vcat (map ppr sigs),
  88              ppr bind
  89        ]
  90      where
  91        ppr_isrec = getPprStyle $ \ sty ->
  92                    if userStyle sty then empty else
  93                    case is_rec of
  94                         Recursive    -> ptext SLIT("{- rec -}")
  95                         NonRecursive -> ptext SLIT("{- nonrec -}")
  96 \end{code}
  97
  98 %************************************************************************
  99 %*                                                                      *
 100 \subsection{Bindings: @MonoBinds@}
 101 %*                                                                      *
 102 %************************************************************************
 103
 104 Global bindings (where clauses)
 105
 106 \begin{code}
 107 data MonoBinds id
 108   = EmptyMonoBinds
 109
 110   | AndMonoBinds    (MonoBinds id)
 111                     (MonoBinds id)
 112
 113   | FunMonoBind     id          -- Used for both functions      f x = e
 114                                 -- and variables                f = \x -> e
 115                                 -- Reason: the Match stuff lets us have an optional
 116                                 --         result type sig      f :: a->a = ...mentions a...
 117                                 --
 118                                 -- This also means that instance decls can only have
 119                                 -- FunMonoBinds, so if you change this, you'll need to
 120                                 -- change e.g. rnMethodBinds
 121                     Bool                -- True => infix declaration
 122                     [Match id]
 123                     SrcLoc
 124
 125   | PatMonoBind     (Pat id)    -- The pattern is never a simple variable;
 126                                 -- That case is done by FunMonoBind
 127                     (GRHSs id)
 128                     SrcLoc
 129
 130   | VarMonoBind     id                  -- TRANSLATION
 131                     (HsExpr id)
 132
 133   | AbsBinds                            -- Binds abstraction; TRANSLATION
 134                 [TyVar]                 -- Type variables
 135                 [id]                    -- Dicts
 136                 [([TyVar], id, id)]     -- (type variables, polymorphic, momonmorphic) triples
 137                 NameSet                 -- Set of *polymorphic* variables that have an INLINE pragma
 138                 (MonoBinds id)      -- The "business end"
 139
 140         -- Creates bindings for *new* (polymorphic, overloaded) locals
 141         -- in terms of *old* (monomorphic, non-overloaded) ones.
 142         --
 143         -- See section 9 of static semantics paper for more details.
 144         -- (You can get a PhD for explaining the True Meaning
 145         --  of this last construct.)
 146 \end{code}
 147
 148 What AbsBinds means
 149 ~~~~~~~~~~~~~~~~~~~
 150          AbsBinds tvs
 151                   [d1,d2]
 152                   [(tvs1, f1p, f1m),
 153                    (tvs2, f2p, f2m)]
 154                   BIND
 155 means
 156
 157         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
 158                                       in fm
 159
 160         gp = ...same again, with gm instead of fm
 161
 162 This is a pretty bad translation, because it duplicates all the bindings.
 163 So the desugarer tries to do a better job:
 164
 165         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
 166                                         (fm,gm) -> fm
 167         ..ditto for gp..
 168
 169         tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
 170                                        in (fm,gm)
 171
 172 \begin{code}
 173 -- We keep the invariant that a MonoBinds is only empty
 174 -- if it is exactly EmptyMonoBinds
 175
 176 nullMonoBinds :: MonoBinds id -> Bool
 177 nullMonoBinds EmptyMonoBinds         = True
 178 nullMonoBinds other_monobind         = False
 179
 180 andMonoBinds :: MonoBinds id -> MonoBinds id -> MonoBinds id
 181 andMonoBinds EmptyMonoBinds mb = mb
 182 andMonoBinds mb EmptyMonoBinds = mb
 183 andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2
 184
 185 andMonoBindList :: [MonoBinds id] -> MonoBinds id
 186 andMonoBindList binds
 187   = loop1 binds
 188   where
 189     loop1 [] = EmptyMonoBinds
 190     loop1 (EmptyMonoBinds : binds) = loop1 binds
 191     loop1 (b:bs) = loop2 b bs
 192
 193         -- acc is non-empty
 194     loop2 acc [] = acc
 195     loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
 196     loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
 197 \end{code}
 198
 199
 200 \begin{code}
 201 instance OutputableBndr id => Outputable (MonoBinds id) where
 202     ppr mbind = ppr_monobind mbind
 203
 204
 205 ppr_monobind :: OutputableBndr id => MonoBinds id -> SDoc
 206 ppr_monobind EmptyMonoBinds = empty
 207 ppr_monobind (AndMonoBinds binds1 binds2)
 208       = ppr_monobind binds1 $$ ppr_monobind binds2
 209
 210 ppr_monobind (PatMonoBind pat grhss locn)       = pprPatBind pat grhss
 211 ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches
 212       -- ToDo: print infix if appropriate
 213
 214 ppr_monobind (VarMonoBind name expr)
 215       = sep [pprBndr LetBind name <+> equals, nest 4 (pprExpr expr)]
 216
 217 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
 218      = sep [ptext SLIT("AbsBinds"),
 219             brackets (interpp'SP tyvars),
 220             brackets (interpp'SP dictvars),
 221             brackets (sep (punctuate comma (map ppr exports))),
 222             brackets (interpp'SP (nameSetToList inlines))]
 223        $$
 224        nest 4 ( vcat [pprBndr LetBind x | (_,x,_) <- exports]
 225                         -- Print type signatures
 226                 $$
 227                 ppr val_binds )
 228 \end{code}
 229
 230 %************************************************************************
 231 %*                                                                      *
 232 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 233 %*                                                                      *
 234 %************************************************************************
 235
 236 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 237 ``specialise this function to these four types...'') in with type
 238 signatures.  Then all the machinery to move them into place, etc.,
 239 serves for both.
 240
 241 \begin{code}
 242 data Sig name
 243   = Sig         name            -- a bog-std type signature
 244                 (HsType name)
 245                 SrcLoc
 246
 247   | SpecSig     name            -- specialise a function or datatype ...
 248                 (HsType name)   -- ... to these types
 249                 SrcLoc
 250
 251   | InlineSig   Bool            -- True <=> INLINE f, False <=> NOINLINE f
 252                 name            -- Function name
 253                 Activation      -- When inlining is *active*
 254                 SrcLoc
 255
 256   | SpecInstSig (HsType name)   -- (Class tys); should be a specialisation of the
 257                                 -- current instance decl
 258                 SrcLoc
 259
 260   | FixSig      (FixitySig name)        -- Fixity declaration
 261
 262 data FixitySig name = FixitySig name Fixity SrcLoc
 263 \end{code}
 264
 265 \begin{code}
 266 okBindSig :: NameSet -> Sig Name -> Bool
 267 okBindSig ns sig                  = sigForThisGroup ns sig
 268
 269 okClsDclSig :: Sig Name -> Bool
 270 okClsDclSig (SpecInstSig _ _) = False
 271 okClsDclSig sig               = True    -- All others OK
 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 :: NameSet -> Sig Name -> Bool
 280 sigForThisGroup ns sig
 281   = case sigName sig of
 282         Nothing -> False
 283         Just n  -> n `elemNameSet` ns
 284
 285 sigName :: Sig name -> Maybe name
 286 sigName (Sig         n _ _)        = Just n
 287 sigName (SpecSig     n _ _)        = Just n
 288 sigName (InlineSig _ n _ _)        = Just n
 289 sigName (FixSig (FixitySig n _ _)) = Just n
 290 sigName other                      = Nothing
 291
 292 sigLoc :: Sig name -> SrcLoc
 293 sigLoc (Sig         _ _ loc)        = loc
 294 sigLoc (SpecSig     _ _ loc)        = loc
 295 sigLoc (InlineSig _ _ _ loc)        = loc
 296 sigLoc (FixSig (FixitySig n _ loc)) = loc
 297 sigLoc (SpecInstSig _ loc)          = loc
 298
 299 isFixitySig :: Sig name -> Bool
 300 isFixitySig (FixSig _) = True
 301 isFixitySig _          = False
 302
 303 isPragSig :: Sig name -> Bool
 304         -- Identifies pragmas
 305 isPragSig (SpecSig _ _ _)     = True
 306 isPragSig (InlineSig _ _ _ _) = True
 307 isPragSig (SpecInstSig _ _)   = True
 308 isPragSig other               = False
 309
 310 hsSigDoc (Sig        _ _ loc)         = (ptext SLIT("type signature"),loc)
 311 hsSigDoc (SpecSig    _ _ loc)         = (ptext SLIT("SPECIALISE pragma"),loc)
 312 hsSigDoc (InlineSig True  _ _ loc)    = (ptext SLIT("INLINE pragma"),loc)
 313 hsSigDoc (InlineSig False _ _ loc)    = (ptext SLIT("NOINLINE pragma"),loc)
 314 hsSigDoc (SpecInstSig _ loc)          = (ptext SLIT("SPECIALISE instance pragma"),loc)
 315 hsSigDoc (FixSig (FixitySig _ _ loc)) = (ptext SLIT("fixity declaration"), loc)
 316 \end{code}
 317
 318 Signature equality is used when checking for duplicate signatures
 319
 320 \begin{code}
 321 eqHsSig :: Sig Name -> Sig Name -> Bool
 322 eqHsSig (FixSig (FixitySig n1 _ _)) (FixSig (FixitySig n2 _ _)) = n1 == n2
 323 eqHsSig (Sig n1 _ _)                (Sig n2 _ _)                = n1 == n2
 324 eqHsSig (InlineSig b1 n1 _ _)       (InlineSig b2 n2 _ _)       = b1 == b2 && n1 == n2
 325         -- For specialisations, we don't have equality over
 326         -- HsType, so it's not convenient to spot duplicate
 327         -- specialisations here.  Check for this later, when we're in Type land
 328 eqHsSig _other1 _other2 = False
 329 \end{code}
 330
 331 \begin{code}
 332 instance (Outputable name) => Outputable (Sig name) where
 333     ppr sig = ppr_sig sig
 334
 335 ppr_sig :: Outputable name => Sig name -> SDoc
 336 ppr_sig (Sig var ty _)
 337       = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 338
 339 ppr_sig (SpecSig var ty _)
 340       = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
 341               nest 4 (ppr ty <+> text "#-}")
 342         ]
 343
 344 ppr_sig (InlineSig True var phase _)
 345       = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"]
 346
 347 ppr_sig (InlineSig False var phase _)
 348       = hsep [text "{-# NOINLINE", ppr phase, ppr var, text "#-}"]
 349
 350 ppr_sig (SpecInstSig ty _)
 351       = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
 352
 353 ppr_sig (FixSig fix_sig) = ppr fix_sig
 354
 355 instance Outputable name => Outputable (FixitySig name) where
 356   ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
 357 \end{code}