compiler/hsSyn/HsBinds.lhs

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