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