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