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