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