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