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: @BindGroup@, @Bind@, @Sig@, @Bind@.
   7
   8 \begin{code}
   9 module HsBinds where
  10
  11 #include "HsVersions.h"
  12
  13 import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr,
  14                                LMatch, pprFunBind,
  15                                GRHSs, pprPatBind )
  16
  17 -- friends:
  18 import HsPat            ( LPat )
  19 import HsTypes          ( LHsType )
  20
  21 --others:
  22 import Name             ( Name )
  23 import NameSet          ( NameSet, elemNameSet, nameSetToList )
  24 import BasicTypes       ( IPName, RecFlag(..), Activation(..), Fixity )
  25 import Outputable
  26 import SrcLoc           ( Located(..), unLoc )
  27 import Var              ( TyVar )
  28 import Bag              ( Bag, bagToList )
  29 \end{code}
  30
  31 %************************************************************************
  32 %*                                                                      *
  33 \subsection{Bindings: @BindGroup@}
  34 %*                                                                      *
  35 %************************************************************************
  36
  37 Global bindings (where clauses)
  38
  39 \begin{code}
  40 data HsBindGroup id
  41   = HsBindGroup                 -- A mutually recursive group
  42         (LHsBinds id)
  43         [LSig id]               -- Empty on typechecker output, Type Signatures
  44         RecFlag
  45
  46   | HsIPBinds
  47         [LIPBind id]            -- Not allowed at top level
  48
  49 instance OutputableBndr id => Outputable (HsBindGroup id) where
  50   ppr (HsBindGroup binds sigs is_rec)
  51      = vcat [ppr_isrec,
  52              vcat (map ppr sigs),
  53              vcat (map ppr (bagToList binds))
  54                 -- *not* pprLHsBinds because we don't want braces; 'let' and
  55                 -- 'where' include a list of HsBindGroups and we don't want
  56                 -- several groups of bindings each with braces around.
  57        ]
  58      where
  59        ppr_isrec = getPprStyle $ \ sty ->
  60                    if userStyle sty then empty else
  61                    case is_rec of
  62                         Recursive    -> ptext SLIT("{- rec -}")
  63                         NonRecursive -> ptext SLIT("{- nonrec -}")
  64
  65   ppr (HsIPBinds ipbinds)
  66      = vcat (map ppr ipbinds)
  67
  68 -- -----------------------------------------------------------------------------
  69 -- Implicit parameter bindings
  70
  71 type LIPBind id = Located (IPBind id)
  72
  73 -- | Implicit parameter bindings.
  74 data IPBind id
  75   = IPBind
  76         (IPName id)
  77         (LHsExpr id)
  78
  79 instance (OutputableBndr id) => Outputable (IPBind id) where
  80     ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
  81
  82 -- -----------------------------------------------------------------------------
  83
  84 type LHsBinds id = Bag (LHsBind id)
  85 type LHsBind  id = Located (HsBind id)
  86
  87 pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc
  88 pprLHsBinds binds = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace
  89
  90 data HsBind id
  91   = FunBind     (Located id)
  92                         -- Used for both functions      f x = e
  93                         -- and variables                f = \x -> e
  94                         -- Reason: the Match stuff lets us have an optional
  95                         --         result type sig      f :: a->a = ...mentions a...
  96                         --
  97                         -- This also means that instance decls can only have
  98                         -- FunBinds, so if you change this, you'll need to
  99                         -- change e.g. rnMethodBinds
 100                 Bool    -- True => infix declaration
 101                 [LMatch id]
 102
 103   | PatBind     (LPat id)       -- The pattern is never a simple variable;
 104                                 -- That case is done by FunBind
 105                 (GRHSs id)
 106
 107   | VarBind id (Located (HsExpr id))    -- Dictionary binding and suchlike;
 108                                         -- located only for consistency
 109
 110   | AbsBinds                            -- Binds abstraction; TRANSLATION
 111                 [TyVar]                 -- Type variables
 112                 [id]                    -- Dicts
 113                 [([TyVar], id, id)]     -- (type variables, polymorphic, momonmorphic) triples
 114                 NameSet                 -- Set of *polymorphic* variables that have an INLINE pragma
 115                 (LHsBinds id)           -- The "business end"
 116
 117         -- Creates bindings for *new* (polymorphic, overloaded) locals
 118         -- in terms of *old* (monomorphic, non-overloaded) ones.
 119         --
 120         -- See section 9 of static semantics paper for more details.
 121         -- (You can get a PhD for explaining the True Meaning
 122         --  of this last construct.)
 123 \end{code}
 124
 125 What AbsBinds means
 126 ~~~~~~~~~~~~~~~~~~~
 127          AbsBinds tvs
 128                   [d1,d2]
 129                   [(tvs1, f1p, f1m),
 130                    (tvs2, f2p, f2m)]
 131                   BIND
 132 means
 133
 134         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
 135                                       in fm
 136
 137         gp = ...same again, with gm instead of fm
 138
 139 This is a pretty bad translation, because it duplicates all the bindings.
 140 So the desugarer tries to do a better job:
 141
 142         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
 143                                         (fm,gm) -> fm
 144         ..ditto for gp..
 145
 146         tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
 147                                        in (fm,gm)
 148
 149 \begin{code}
 150 instance OutputableBndr id => Outputable (HsBind id) where
 151     ppr mbind = ppr_monobind mbind
 152
 153 ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
 154
 155 ppr_monobind (PatBind pat grhss)       = pprPatBind pat grhss
 156 ppr_monobind (VarBind var rhs)         = ppr var <+> equals <+> pprExpr (unLoc rhs)
 157 ppr_monobind (FunBind fun inf matches) = pprFunBind (unLoc fun) matches
 158       -- ToDo: print infix if appropriate
 159
 160 ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
 161      = sep [ptext SLIT("AbsBinds"),
 162             brackets (interpp'SP tyvars),
 163             brackets (interpp'SP dictvars),
 164             brackets (sep (punctuate comma (map ppr exports))),
 165             brackets (interpp'SP (nameSetToList inlines))]
 166        $$
 167        nest 4 ( vcat [pprBndr LetBind x | (_,x,_) <- exports]
 168                         -- Print type signatures
 169                 $$
 170                 pprLHsBinds val_binds )
 171 \end{code}
 172
 173 %************************************************************************
 174 %*                                                                      *
 175 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 176 %*                                                                      *
 177 %************************************************************************
 178
 179 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 180 ``specialise this function to these four types...'') in with type
 181 signatures.  Then all the machinery to move them into place, etc.,
 182 serves for both.
 183
 184 \begin{code}
 185 type LSig name = Located (Sig name)
 186
 187 data Sig name
 188   = Sig         (Located name)  -- a bog-std type signature
 189                 (LHsType name)
 190
 191   | SpecSig     (Located name)  -- specialise a function or datatype ...
 192                 (LHsType name)  -- ... to these types
 193
 194   | InlineSig   Bool            -- True <=> INLINE f, False <=> NOINLINE f
 195                 (Located name)  -- Function name
 196                 Activation      -- When inlining is *active*
 197
 198   | SpecInstSig (LHsType name)  -- (Class tys); should be a specialisation of the
 199                                 -- current instance decl
 200
 201   | FixSig      (FixitySig name)        -- Fixity declaration
 202
 203 type LFixitySig name = Located (FixitySig name)
 204 data FixitySig name = FixitySig (Located name) Fixity
 205 \end{code}
 206
 207 \begin{code}
 208 okBindSig :: NameSet -> LSig Name -> Bool
 209 okBindSig ns sig = sigForThisGroup ns sig
 210
 211 okClsDclSig :: LSig Name -> Bool
 212 okClsDclSig (L _ (SpecInstSig _)) = False
 213 okClsDclSig sig                   = True        -- All others OK
 214
 215 okInstDclSig :: NameSet -> LSig Name -> Bool
 216 okInstDclSig ns lsig@(L _ sig) = ok ns sig
 217   where
 218     ok ns (Sig _ _)       = False
 219     ok ns (FixSig _)      = False
 220     ok ns (SpecInstSig _) = True
 221     ok ns sig             = sigForThisGroup ns lsig
 222
 223 sigForThisGroup :: NameSet -> LSig Name -> Bool
 224 sigForThisGroup ns sig
 225   = case sigName sig of
 226         Nothing -> False
 227         Just n  -> n `elemNameSet` ns
 228
 229 sigName :: LSig name -> Maybe name
 230 sigName (L _ sig) = f sig
 231  where
 232     f (Sig         n _)        = Just (unLoc n)
 233     f (SpecSig     n _)        = Just (unLoc n)
 234     f (InlineSig _ n _)        = Just (unLoc n)
 235     f (FixSig (FixitySig n _)) = Just (unLoc n)
 236     f other                     = Nothing
 237
 238 isFixitySig :: Sig name -> Bool
 239 isFixitySig (FixSig _) = True
 240 isFixitySig _          = False
 241
 242 isPragSig :: Sig name -> Bool
 243         -- Identifies pragmas
 244 isPragSig (SpecSig _ _)     = True
 245 isPragSig (InlineSig _ _ _) = True
 246 isPragSig (SpecInstSig _)   = True
 247 isPragSig other             = False
 248
 249 hsSigDoc (Sig        _ _)         = ptext SLIT("type signature")
 250 hsSigDoc (SpecSig    _ _)         = ptext SLIT("SPECIALISE pragma")
 251 hsSigDoc (InlineSig True  _ _)    = ptext SLIT("INLINE pragma")
 252 hsSigDoc (InlineSig False _ _)    = ptext SLIT("NOINLINE pragma")
 253 hsSigDoc (SpecInstSig _)          = ptext SLIT("SPECIALISE instance pragma")
 254 hsSigDoc (FixSig (FixitySig _ _)) = ptext SLIT("fixity declaration")
 255 \end{code}
 256
 257 Signature equality is used when checking for duplicate signatures
 258
 259 \begin{code}
 260 eqHsSig :: Sig Name -> Sig Name -> Bool
 261 eqHsSig (FixSig (FixitySig n1 _)) (FixSig (FixitySig n2 _)) = unLoc n1 == unLoc n2
 262 eqHsSig (Sig n1 _)                  (Sig n2 _)              = unLoc n1 == unLoc n2
 263 eqHsSig (InlineSig b1 n1 _)         (InlineSig b2 n2 _)     = b1 == b2 && unLoc n1 == unLoc n2
 264         -- For specialisations, we don't have equality over
 265         -- HsType, so it's not convenient to spot duplicate
 266         -- specialisations here.  Check for this later, when we're in Type land
 267 eqHsSig _other1 _other2 = False
 268 \end{code}
 269
 270 \begin{code}
 271 instance (OutputableBndr name) => Outputable (Sig name) where
 272     ppr sig = ppr_sig sig
 273
 274 ppr_sig :: OutputableBndr name => Sig name -> SDoc
 275 ppr_sig (Sig var ty)
 276       = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
 277
 278 ppr_sig (SpecSig var ty)
 279       = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
 280               nest 4 (ppr ty <+> text "#-}")
 281         ]
 282
 283 ppr_sig (InlineSig True var phase)
 284       = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"]
 285
 286 ppr_sig (InlineSig False var phase)
 287       = hsep [text "{-# NOINLINE", ppr phase, ppr var, text "#-}"]
 288
 289 ppr_sig (SpecInstSig ty)
 290       = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
 291
 292 ppr_sig (FixSig fix_sig) = ppr fix_sig
 293
 294 instance Outputable name => Outputable (FixitySig name) where
 295   ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
 296 \end{code}