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