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: @BindGroup@, @Bind@, @Sig@, @Bind@.
   7
   8 \begin{code}
   9 module HsBinds where
  10
  11 #include "HsVersions.h"
  12
  13 import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr,
  14                                MatchGroup, pprFunBind,
  15                                GRHSs, pprPatBind )
  16 import {-# SOURCE #-} HsPat  ( LPat )
  17
  18 import HsTypes          ( LHsType, PostTcType )
  19 import Type             ( Type )
  20 import Name             ( Name )
  21 import NameSet          ( NameSet, elemNameSet )
  22 import BasicTypes       ( IPName, RecFlag(..), InlineSpec(..), Fixity )
  23 import Outputable
  24 import SrcLoc           ( Located(..), SrcSpan, unLoc )
  25 import Util             ( sortLe )
  26 import Var              ( TyVar, DictId, Id )
  27 import Bag              ( Bag, emptyBag, isEmptyBag, bagToList, unionBags, unionManyBags )
  28 \end{code}
  29
  30 %************************************************************************
  31 %*                                                                      *
  32 \subsection{Bindings: @BindGroup@}
  33 %*                                                                      *
  34 %************************************************************************
  35
  36 Global bindings (where clauses)
  37
  38 \begin{code}
  39 data HsLocalBinds id    -- Bindings in a 'let' expression
  40                         -- or a 'where' clause
  41   = HsValBinds (HsValBinds id)
  42   | HsIPBinds  (HsIPBinds id)
  43
  44   | EmptyLocalBinds
  45
  46 data HsValBinds id      -- Value bindings (not implicit parameters)
  47   = ValBindsIn                          -- Before typechecking
  48         (LHsBinds id) [LSig id]         -- Not dependency analysed
  49                                         -- Recursive by default
  50
  51   | ValBindsOut                         -- After renaming
  52         [(RecFlag, LHsBinds id)]        -- Dependency analysed
  53         [LSig Name]
  54
  55 type LHsBinds id  = Bag (LHsBind id)
  56 type DictBinds id = LHsBinds id         -- Used for dictionary or method bindings
  57 type LHsBind  id  = Located (HsBind id)
  58
  59 data HsBind id
  60   = FunBind {   -- FunBind is used for both functions   f x = e
  61                 -- and variables                        f = \x -> e
  62 -- Reason 1: the Match stuff lets us have an optional
  63 --         result type sig      f :: a->a = ...mentions a...
  64 --
  65 -- Reason 2: Special case for type inference: see TcBinds.tcMonoBinds
  66 --
  67 -- Reason 3: instance decls can only have FunBinds, which is convenient
  68 --           If you change this, you'll need tochange e.g. rnMethodBinds
  69
  70         fun_id :: Located id,
  71
  72         fun_infix :: Bool,      -- True => infix declaration
  73
  74         fun_matches :: MatchGroup id,   -- The payload
  75
  76         fun_co_fn :: ExprCoFn,  -- Coercion from the type of the MatchGroup to the type of
  77                                 -- the Id.  Example:
  78                                 --      f :: Int -> forall a. a -> a
  79                                 --      f x y = y
  80                                 -- Then the MatchGroup will have type (Int -> a' -> a')
  81                                 -- (with a free type variable a').  The coercion will take
  82                                 -- a CoreExpr of this type and convert it to a CoreExpr of
  83                                 -- type         Int -> forall a'. a' -> a'
  84                                 -- Notice that the coercion captures the free a'.  That's
  85                                 -- why coercions are (CoreExpr -> CoreExpr), rather than
  86                                 -- just CoreExpr (with a functional type)
  87
  88         bind_fvs :: NameSet     -- After the renamer, this contains a superset of the
  89                                 -- Names of the other binders in this binding group that
  90                                 -- are free in the RHS of the defn
  91                                 -- Before renaming, and after typechecking,
  92                                 -- the field is unused; it's just an error thunk
  93     }
  94
  95   | PatBind {   -- The pattern is never a simple variable;
  96                 -- That case is done by FunBind
  97         pat_lhs    :: LPat id,
  98         pat_rhs    :: GRHSs id,
  99         pat_rhs_ty :: PostTcType,       -- Type of the GRHSs
 100         bind_fvs   :: NameSet           -- Same as for FunBind
 101     }
 102
 103   | VarBind {   -- Dictionary binding and suchlike
 104         var_id :: id,           -- All VarBinds are introduced by the type checker
 105         var_rhs :: LHsExpr id   -- Located only for consistency
 106     }
 107
 108   | AbsBinds {                                  -- Binds abstraction; TRANSLATION
 109         abs_tvs     :: [TyVar],
 110         abs_dicts   :: [DictId],
 111         abs_exports :: [([TyVar], id, id, [Prag])],     -- (tvs, poly_id, mono_id, prags)
 112         abs_binds   :: LHsBinds id              -- The dictionary bindings and typechecked user bindings
 113                                                 -- mixed up together; you can tell the dict bindings because
 114                                                 -- they are all VarBinds
 115     }
 116         -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
 117         --
 118         -- Creates bindings for (polymorphic, overloaded) poly_f
 119         -- in terms of monomorphic, non-overloaded mono_f
 120         --
 121         -- Invariants:
 122         --      1. 'binds' binds mono_f
 123         --      2. ftvs is a subset of tvs
 124         --      3. ftvs includes all tyvars free in ds
 125         --
 126         -- See section 9 of static semantics paper for more details.
 127         -- (You can get a PhD for explaining the True Meaning
 128         --  of this last construct.)
 129
 130 placeHolderNames :: NameSet
 131 -- Used for the NameSet in FunBind and PatBind prior to the renamer
 132 placeHolderNames = panic "placeHolderNames"
 133
 134 ------------
 135 instance OutputableBndr id => Outputable (HsLocalBinds id) where
 136   ppr (HsValBinds bs) = ppr bs
 137   ppr (HsIPBinds bs)  = ppr bs
 138   ppr EmptyLocalBinds = empty
 139
 140 instance OutputableBndr id => Outputable (HsValBinds id) where
 141   ppr (ValBindsIn binds sigs)
 142    = pprValBindsForUser binds sigs
 143
 144   ppr (ValBindsOut sccs sigs)
 145     = getPprStyle $ \ sty ->
 146       if debugStyle sty then    -- Print with sccs showing
 147         vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
 148      else
 149         pprValBindsForUser (unionManyBags (map snd sccs)) sigs
 150    where
 151      ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
 152      pp_rec Recursive    = ptext SLIT("rec")
 153      pp_rec NonRecursive = ptext SLIT("nonrec")
 154
 155 --  *not* pprLHsBinds because we don't want braces; 'let' and
 156 -- 'where' include a list of HsBindGroups and we don't want
 157 -- several groups of bindings each with braces around.
 158 -- Sort by location before printing
 159 pprValBindsForUser :: (OutputableBndr id1, OutputableBndr id2)
 160                    => LHsBinds id1 -> [LSig id2] -> SDoc
 161 pprValBindsForUser binds sigs
 162   = vcat (map snd (sort_by_loc decls))
 163   where
 164
 165     decls :: [(SrcSpan, SDoc)]
 166     decls = [(loc, ppr sig)  | L loc sig <- sigs] ++
 167             [(loc, ppr bind) | L loc bind <- bagToList binds]
 168
 169     sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls
 170
 171 pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc
 172 pprLHsBinds binds
 173   | isEmptyLHsBinds binds = empty
 174   | otherwise = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace
 175
 176 ------------
 177 emptyLocalBinds :: HsLocalBinds a
 178 emptyLocalBinds = EmptyLocalBinds
 179
 180 isEmptyLocalBinds :: HsLocalBinds a -> Bool
 181 isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
 182 isEmptyLocalBinds (HsIPBinds ds)  = isEmptyIPBinds ds
 183 isEmptyLocalBinds EmptyLocalBinds = True
 184
 185 isEmptyValBinds :: HsValBinds a -> Bool
 186 isEmptyValBinds (ValBindsIn ds sigs)  = isEmptyLHsBinds ds && null sigs
 187 isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
 188
 189 emptyValBindsIn, emptyValBindsOut :: HsValBinds a
 190 emptyValBindsIn  = ValBindsIn emptyBag []
 191 emptyValBindsOut = ValBindsOut []      []
 192
 193 emptyLHsBinds :: LHsBinds id
 194 emptyLHsBinds = emptyBag
 195
 196 isEmptyLHsBinds :: LHsBinds id -> Bool
 197 isEmptyLHsBinds = isEmptyBag
 198
 199 ------------
 200 plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
 201 plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
 202   = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
 203 plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
 204   = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
 205 \end{code}
 206
 207 What AbsBinds means
 208 ~~~~~~~~~~~~~~~~~~~
 209          AbsBinds tvs
 210                   [d1,d2]
 211                   [(tvs1, f1p, f1m),
 212                    (tvs2, f2p, f2m)]
 213                   BIND
 214 means
 215
 216         f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND
 217                                       in fm
 218
 219         gp = ...same again, with gm instead of fm
 220
 221 This is a pretty bad translation, because it duplicates all the bindings.
 222 So the desugarer tries to do a better job:
 223
 224         fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
 225                                         (fm,gm) -> fm
 226         ..ditto for gp..
 227
 228         tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND
 229                                        in (fm,gm)
 230
 231 \begin{code}
 232 instance OutputableBndr id => Outputable (HsBind id) where
 233     ppr mbind = ppr_monobind mbind
 234
 235 ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
 236
 237 ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })      = pprPatBind pat grhss
 238 ppr_monobind (VarBind { var_id = var, var_rhs = rhs })         = ppr var <+> equals <+> pprExpr (unLoc rhs)
 239 ppr_monobind (FunBind { fun_id = fun, fun_matches = matches }) = pprFunBind (unLoc fun) matches
 240       -- ToDo: print infix if appropriate
 241
 242 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars,
 243                          abs_exports = exports, abs_binds = val_binds })
 244      = sep [ptext SLIT("AbsBinds"),
 245             brackets (interpp'SP tyvars),
 246             brackets (interpp'SP dictvars),
 247             brackets (sep (punctuate comma (map ppr_exp exports)))]
 248        $$
 249        nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
 250                         -- Print type signatures
 251                 $$ pprLHsBinds val_binds )
 252   where
 253     ppr_exp (tvs, gbl, lcl, prags)
 254         = vcat [ppr gbl <+> ptext SLIT("<=") <+> ppr tvs <+> ppr lcl,
 255                 nest 2 (vcat (map (pprPrag gbl) prags))]
 256 \end{code}
 257
 258 %************************************************************************
 259 %*                                                                      *
 260                 Implicit parameter bindings
 261 %*                                                                      *
 262 %************************************************************************
 263
 264 \begin{code}
 265 data HsIPBinds id
 266   = IPBinds
 267         [LIPBind id]
 268         (DictBinds id)  -- Only in typechecker output; binds
 269                         -- uses of the implicit parameters
 270
 271 isEmptyIPBinds :: HsIPBinds id -> Bool
 272 isEmptyIPBinds (IPBinds is ds) = null is && isEmptyBag ds
 273
 274 type LIPBind id = Located (IPBind id)
 275
 276 -- | Implicit parameter bindings.
 277 data IPBind id
 278   = IPBind
 279         (IPName id)
 280         (LHsExpr id)
 281
 282 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
 283   ppr (IPBinds bs ds) = vcat (map ppr bs)
 284                         $$ pprLHsBinds ds
 285
 286 instance (OutputableBndr id) => Outputable (IPBind id) where
 287   ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
 288 \end{code}
 289
 290
 291 %************************************************************************
 292 %*                                                                      *
 293 \subsection{Coercion functions}
 294 %*                                                                      *
 295 %************************************************************************
 296
 297 \begin{code}
 298 -- A Coercion is an expression with a hole in it
 299 -- We need coercions to have concrete form so that we can zonk them
 300
 301 data ExprCoFn
 302   = CoHole                      -- The identity coercion
 303   | CoCompose ExprCoFn ExprCoFn
 304   | CoApps ExprCoFn [Id]                -- Non-empty list
 305   | CoTyApps ExprCoFn [Type]            --   in all of these
 306   | CoLams [Id] ExprCoFn                --   so that the identity coercion
 307   | CoTyLams [TyVar] ExprCoFn           --   is just Hole
 308   | CoLet (LHsBinds Id) ExprCoFn        -- Would be nicer to be core bindings
 309
 310 (<.>) :: ExprCoFn -> ExprCoFn -> ExprCoFn
 311 (<.>) = CoCompose
 312
 313 idCoercion :: ExprCoFn
 314 idCoercion = CoHole
 315
 316 isIdCoercion :: ExprCoFn -> Bool
 317 isIdCoercion CoHole = True
 318 isIdCoercion other  = False
 319 \end{code}
 320
 321
 322 %************************************************************************
 323 %*                                                                      *
 324 \subsection{@Sig@: type signatures and value-modifying user pragmas}
 325 %*                                                                      *
 326 %************************************************************************
 327
 328 It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
 329 ``specialise this function to these four types...'') in with type
 330 signatures.  Then all the machinery to move them into place, etc.,
 331 serves for both.
 332
 333 \begin{code}
 334 type LSig name = Located (Sig name)
 335
 336 data Sig name
 337   = TypeSig     (Located name)  -- A bog-std type signature
 338                 (LHsType name)
 339
 340   | SpecSig     (Located name)  -- Specialise a function or datatype ...
 341                 (LHsType name)  -- ... to these types
 342                 InlineSpec
 343
 344   | InlineSig   (Located name)  -- Function name
 345                 InlineSpec
 346
 347   | SpecInstSig (LHsType name)  -- (Class tys); should be a specialisation of the
 348                                 -- current instance decl
 349
 350   | FixSig      (FixitySig name)        -- Fixity declaration
 351
 352 type LFixitySig name = Located (FixitySig name)
 353 data FixitySig name = FixitySig (Located name) Fixity
 354
 355 -- A Prag conveys pragmas from the type checker to the desugarer
 356 data Prag
 357   = InlinePrag
 358         InlineSpec
 359
 360   | SpecPrag
 361         (HsExpr Id)     -- An expression, of the given specialised type, which
 362         PostTcType      -- specialises the polymorphic function
 363         [Id]            -- Dicts mentioned free in the expression
 364         InlineSpec      -- Inlining spec for the specialised function
 365
 366 isInlinePrag (InlinePrag _) = True
 367 isInlinePrag prag           = False
 368
 369 isSpecPrag (SpecPrag _ _ _ _) = True
 370 isSpecPrag prag               = False
 371 \end{code}
 372
 373 \begin{code}
 374 okBindSig :: NameSet -> LSig Name -> Bool
 375 okBindSig ns sig = sigForThisGroup ns sig
 376
 377 okHsBootSig :: LSig Name -> Bool
 378 okHsBootSig (L _ (TypeSig  _ _)) = True
 379 okHsBootSig (L _ (FixSig _))     = True
 380 okHsBootSig sig                  = False
 381
 382 okClsDclSig :: LSig Name -> Bool
 383 okClsDclSig (L _ (SpecInstSig _)) = False
 384 okClsDclSig sig                   = True        -- All others OK
 385
 386 okInstDclSig :: NameSet -> LSig Name -> Bool
 387 okInstDclSig ns lsig@(L _ sig) = ok ns sig
 388   where
 389     ok ns (TypeSig _ _)   = False
 390     ok ns (FixSig _)      = False
 391     ok ns (SpecInstSig _) = True
 392     ok ns sig             = sigForThisGroup ns lsig
 393
 394 sigForThisGroup :: NameSet -> LSig Name -> Bool
 395 sigForThisGroup ns sig
 396   = case sigName sig of
 397         Nothing -> False
 398         Just n  -> n `elemNameSet` ns
 399
 400 sigName :: LSig name -> Maybe name
 401 sigName (L _ sig) = f sig
 402  where
 403     f (TypeSig   n _)          = Just (unLoc n)
 404     f (SpecSig   n _ _)        = Just (unLoc n)
 405     f (InlineSig n _)          = Just (unLoc n)
 406     f (FixSig (FixitySig n _)) = Just (unLoc n)
 407     f other                     = Nothing
 408
 409 isFixityLSig :: LSig name -> Bool
 410 isFixityLSig (L _ (FixSig {})) = True
 411 isFixityLSig _                 = False
 412
 413 isVanillaLSig :: LSig name -> Bool
 414 isVanillaLSig (L _(TypeSig {})) = True
 415 isVanillaLSig sig               = False
 416
 417 isSpecLSig :: LSig name -> Bool
 418 isSpecLSig (L _(SpecSig {})) = True
 419 isSpecLSig sig               = False
 420
 421 isSpecInstLSig (L _ (SpecInstSig {})) = True
 422 isSpecInstLSig sig                    = False
 423
 424 isPragLSig :: LSig name -> Bool
 425         -- Identifies pragmas
 426 isPragLSig (L _ (SpecSig {}))   = True
 427 isPragLSig (L _ (InlineSig {})) = True
 428 isPragLSig other                = False
 429
 430 isInlineLSig :: LSig name -> Bool
 431         -- Identifies inline pragmas
 432 isInlineLSig (L _ (InlineSig {})) = True
 433 isInlineLSig other                = False
 434
 435 hsSigDoc (TypeSig {})           = ptext SLIT("type signature")
 436 hsSigDoc (SpecSig {})           = ptext SLIT("SPECIALISE pragma")
 437 hsSigDoc (InlineSig _ spec)     = ppr spec <+> ptext SLIT("pragma")
 438 hsSigDoc (SpecInstSig {})       = ptext SLIT("SPECIALISE instance pragma")
 439 hsSigDoc (FixSig {})            = ptext SLIT("fixity declaration")
 440 \end{code}
 441
 442 Signature equality is used when checking for duplicate signatures
 443
 444 \begin{code}
 445 eqHsSig :: LSig Name -> LSig Name -> Bool
 446 eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
 447 eqHsSig (L _ (TypeSig n1 _))            (L _ (TypeSig n2 _))            = unLoc n1 == unLoc n2
 448 eqHsSig (L _ (InlineSig n1 s1)) (L _ (InlineSig n2 s2))                 = s1 == s2 && unLoc n1 == unLoc n2
 449         -- For specialisations, we don't have equality over
 450         -- HsType, so it's not convenient to spot duplicate
 451         -- specialisations here.  Check for this later, when we're in Type land
 452 eqHsSig _other1 _other2 = False
 453 \end{code}
 454
 455 \begin{code}
 456 instance (OutputableBndr name) => Outputable (Sig name) where
 457     ppr sig = ppr_sig sig
 458
 459 ppr_sig :: OutputableBndr name => Sig name -> SDoc
 460 ppr_sig (TypeSig var ty)          = pprVarSig (unLoc var) ty
 461 ppr_sig (FixSig fix_sig)          = ppr fix_sig
 462 ppr_sig (SpecSig var ty inl)      = pragBrackets (pprSpec var ty inl)
 463 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> ppr var)
 464 ppr_sig (SpecInstSig ty)          = pragBrackets (ptext SLIT("SPECIALIZE instance") <+> ppr ty)
 465
 466 instance Outputable name => Outputable (FixitySig name) where
 467   ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
 468
 469 pragBrackets :: SDoc -> SDoc
 470 pragBrackets doc = ptext SLIT("{-#") <+> doc <+> ptext SLIT("#-}")
 471
 472 pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc
 473 pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)]
 474
 475 pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc
 476 pprSpec var ty inl = sep [ptext SLIT("SPECIALIZE") <+> ppr inl <+> pprVarSig var ty]
 477
 478 pprPrag :: Outputable id => id -> Prag -> SDoc
 479 pprPrag var (InlinePrag inl)         = ppr inl <+> ppr var
 480 pprPrag var (SpecPrag expr ty _ inl) = pprSpec var ty inl
 481 \end{code}