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