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