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