ghc/compiler/typecheck/TcBinds.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcBinds]{TcBinds}
   5
   6 \begin{code}
   7 module TcBinds ( tcLocalBinds, tcTopBinds,
   8                  tcHsBootSigs, tcMonoBinds,
   9                  TcPragFun, tcSpecPrag, tcPrags, mkPragFun,
  10                  badBootDeclErr ) where
  11
  12 #include "HsVersions.h"
  13
  14 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
  15 import {-# SOURCE #-} TcExpr  ( tcCheckRho )
  16
  17 import DynFlags         ( DynFlag(Opt_MonomorphismRestriction, Opt_GlasgowExts) )
  18 import HsSyn            ( HsExpr(..), HsBind(..), LHsBinds, LHsBind, Sig(..),
  19                           HsLocalBinds(..), HsValBinds(..), HsIPBinds(..),
  20                           LSig, Match(..), IPBind(..), Prag(..),
  21                           HsType(..), LHsType, HsExplicitForAll(..), hsLTyVarNames,
  22                           isVanillaLSig, sigName, placeHolderNames, isPragLSig,
  23                           LPat, GRHSs, MatchGroup(..), isEmptyLHsBinds,
  24                           collectHsBindBinders, collectPatBinders, pprPatBind
  25                         )
  26 import TcHsSyn          ( zonkId, (<$>) )
  27
  28 import TcRnMonad
  29 import Inst             ( newDictsAtLoc, newIPDict, instToId )
  30 import TcEnv            ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2,
  31                           tcLookupLocalIds, pprBinders,
  32                           tcGetGlobalTyVars )
  33 import TcUnify          ( Expected(..), tcInfer, unifyTheta, tcSub,
  34                           bleatEscapedTvs, sigCtxt )
  35 import TcSimplify       ( tcSimplifyInfer, tcSimplifyInferCheck,
  36                           tcSimplifyRestricted, tcSimplifyIPs )
  37 import TcHsType         ( tcHsSigType, UserTypeCtxt(..), tcAddLetBoundTyVars,
  38                           TcSigInfo(..), TcSigFun, lookupSig
  39                         )
  40 import TcPat            ( tcPat, PatCtxt(..) )
  41 import TcSimplify       ( bindInstsOfLocalFuns )
  42 import TcMType          ( newTyFlexiVarTy, zonkQuantifiedTyVar,
  43                           tcInstSigType, zonkTcType, zonkTcTypes, zonkTcTyVar )
  44 import TcType           ( TcType, TcTyVar, SkolemInfo(SigSkol),
  45                           TcTauType, TcSigmaType, isUnboxedTupleType,
  46                           mkTyVarTy, mkForAllTys, mkFunTys, tyVarsOfType,
  47                           mkForAllTy, isUnLiftedType, tcGetTyVar,
  48                           mkTyVarTys, tidyOpenTyVar )
  49 import Kind             ( argTypeKind )
  50 import VarEnv           ( TyVarEnv, emptyVarEnv, lookupVarEnv, extendVarEnv, emptyTidyEnv )
  51 import TysPrim          ( alphaTyVar )
  52 import Id               ( Id, mkLocalId, mkVanillaGlobal )
  53 import IdInfo           ( vanillaIdInfo )
  54 import Var              ( TyVar, idType, idName )
  55 import Name             ( Name )
  56 import NameSet
  57 import NameEnv
  58 import VarSet
  59 import SrcLoc           ( Located(..), unLoc, getLoc )
  60 import Bag
  61 import ErrUtils         ( Message )
  62 import Digraph          ( SCC(..), stronglyConnComp, flattenSCC )
  63 import Maybes           ( fromJust, isJust, orElse, catMaybes )
  64 import Util             ( singleton )
  65 import BasicTypes       ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
  66                           RecFlag(..), isNonRec )
  67 import Outputable
  68 \end{code}
  69
  70
  71 %************************************************************************
  72 %*                                                                      *
  73 \subsection{Type-checking bindings}
  74 %*                                                                      *
  75 %************************************************************************
  76
  77 @tcBindsAndThen@ typechecks a @HsBinds@.  The "and then" part is because
  78 it needs to know something about the {\em usage} of the things bound,
  79 so that it can create specialisations of them.  So @tcBindsAndThen@
  80 takes a function which, given an extended environment, E, typechecks
  81 the scope of the bindings returning a typechecked thing and (most
  82 important) an LIE.  It is this LIE which is then used as the basis for
  83 specialising the things bound.
  84
  85 @tcBindsAndThen@ also takes a "combiner" which glues together the
  86 bindings and the "thing" to make a new "thing".
  87
  88 The real work is done by @tcBindWithSigsAndThen@.
  89
  90 Recursive and non-recursive binds are handled in essentially the same
  91 way: because of uniques there are no scoping issues left.  The only
  92 difference is that non-recursive bindings can bind primitive values.
  93
  94 Even for non-recursive binding groups we add typings for each binder
  95 to the LVE for the following reason.  When each individual binding is
  96 checked the type of its LHS is unified with that of its RHS; and
  97 type-checking the LHS of course requires that the binder is in scope.
  98
  99 At the top-level the LIE is sure to contain nothing but constant
 100 dictionaries, which we resolve at the module level.
 101
 102 \begin{code}
 103 tcTopBinds :: HsValBinds Name -> TcM (LHsBinds TcId, TcLclEnv)
 104         -- Note: returning the TcLclEnv is more than we really
 105         --       want.  The bit we care about is the local bindings
 106         --       and the free type variables thereof
 107 tcTopBinds binds
 108   = do  { (ValBindsOut prs, env) <- tcValBinds TopLevel binds getLclEnv
 109         ; return (foldr (unionBags . snd) emptyBag prs, env) }
 110         -- The top level bindings are flattened into a giant
 111         -- implicitly-mutually-recursive LHsBinds
 112
 113 tcHsBootSigs :: HsValBinds Name -> TcM [Id]
 114 -- A hs-boot file has only one BindGroup, and it only has type
 115 -- signatures in it.  The renamer checked all this
 116 tcHsBootSigs (ValBindsIn binds sigs)
 117   = do  { checkTc (isEmptyLHsBinds binds) badBootDeclErr
 118         ; mapM (addLocM tc_boot_sig) (filter isVanillaLSig sigs) }
 119   where
 120     tc_boot_sig (Sig (L _ name) ty)
 121       = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
 122            ; return (mkVanillaGlobal name sigma_ty vanillaIdInfo) }
 123         -- Notice that we make GlobalIds, not LocalIds
 124 tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups)
 125
 126 badBootDeclErr :: Message
 127 badBootDeclErr = ptext SLIT("Illegal declarations in an hs-boot file")
 128
 129 ------------------------
 130 tcLocalBinds :: HsLocalBinds Name -> TcM thing
 131              -> TcM (HsLocalBinds TcId, thing)
 132
 133 tcLocalBinds EmptyLocalBinds thing_inside
 134   = do  { thing <- thing_inside
 135         ; return (EmptyLocalBinds, thing) }
 136
 137 tcLocalBinds (HsValBinds binds) thing_inside
 138   = do  { (binds', thing) <- tcValBinds NotTopLevel binds thing_inside
 139         ; return (HsValBinds binds', thing) }
 140
 141 tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
 142   = do  { (thing, lie) <- getLIE thing_inside
 143         ; (avail_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds
 144
 145         -- If the binding binds ?x = E, we  must now
 146         -- discharge any ?x constraints in expr_lie
 147         ; dict_binds <- tcSimplifyIPs avail_ips lie
 148         ; return (HsIPBinds (IPBinds ip_binds' dict_binds), thing) }
 149   where
 150         -- I wonder if we should do these one at at time
 151         -- Consider     ?x = 4
 152         --              ?y = ?x + 1
 153     tc_ip_bind (IPBind ip expr)
 154       = newTyFlexiVarTy argTypeKind             `thenM` \ ty ->
 155         newIPDict (IPBindOrigin ip) ip ty       `thenM` \ (ip', ip_inst) ->
 156         tcCheckRho expr ty                      `thenM` \ expr' ->
 157         returnM (ip_inst, (IPBind ip' expr'))
 158
 159 ------------------------
 160 mkEdges :: (Name -> Bool) -> [LHsBind Name]
 161         -> [(LHsBind Name, BKey, [BKey])]
 162
 163 type BKey  = Int -- Just number off the bindings
 164
 165 mkEdges exclude_fn binds
 166   = [ (bind, key, [fromJust mb_key | n <- nameSetToList (bind_fvs (unLoc bind)),
 167                                      let mb_key = lookupNameEnv key_map n,
 168                                      isJust mb_key,
 169                                      not (exclude_fn n) ])
 170     | (bind, key) <- keyd_binds
 171     ]
 172   where
 173     keyd_binds = binds `zip` [0::BKey ..]
 174
 175     bind_fvs (FunBind _ _ _ fvs) = fvs
 176     bind_fvs (PatBind _ _ _ fvs) = fvs
 177     bind_fvs bind = pprPanic "mkEdges" (ppr bind)
 178
 179     key_map :: NameEnv BKey     -- Which binding it comes from
 180     key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
 181                                      , bndr <- bindersOfHsBind bind ]
 182
 183 bindersOfHsBind :: HsBind Name -> [Name]
 184 bindersOfHsBind (PatBind pat _ _ _)     = collectPatBinders pat
 185 bindersOfHsBind (FunBind (L _ f) _ _ _) = [f]
 186
 187 ------------------------
 188 tcValBinds :: TopLevelFlag
 189            -> HsValBinds Name -> TcM thing
 190            -> TcM (HsValBinds TcId, thing)
 191
 192 tcValBinds top_lvl (ValBindsIn binds sigs) thing_inside
 193   = tcAddLetBoundTyVars binds  $
 194       -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE
 195           -- Notice that they scope over
 196           --       a) the type signatures in the binding group
 197           --       b) the bindings in the group
 198           --       c) the scope of the binding group (the "in" part)
 199
 200     do  {       -- Typecheck the signature
 201           tc_ty_sigs <- recoverM (returnM []) (tcTySigs sigs)
 202
 203                 -- Do the basic strongly-connected component thing
 204         ; let { sccs :: [SCC (LHsBind Name)]
 205               ; sccs = stronglyConnComp (mkEdges (\n -> False) (bagToList binds))
 206               ; prag_fn = mkPragFun sigs
 207               ; sig_fn  = lookupSig tc_ty_sigs
 208               ; sig_ids = map sig_id tc_ty_sigs }
 209
 210                 -- Extend the envt right away with all
 211                 -- the Ids declared with type signatures
 212         ; (binds', thing) <- tcExtendIdEnv sig_ids $
 213                              tc_val_binds top_lvl sig_fn prag_fn
 214                                           sccs thing_inside
 215
 216         ; return (ValBindsOut binds', thing) }
 217
 218 ------------------------
 219 tc_val_binds :: TopLevelFlag -> TcSigFun -> TcPragFun
 220              -> [SCC (LHsBind Name)] -> TcM thing
 221              -> TcM ([(RecFlag, LHsBinds TcId)], thing)
 222 -- Typecheck a whole lot of value bindings,
 223 -- one strongly-connected component at a time
 224
 225 tc_val_binds top_lvl sig_fn prag_fn [] thing_inside
 226   = do  { thing <- thing_inside
 227         ; return ([], thing) }
 228
 229 tc_val_binds top_lvl sig_fn prag_fn (scc : sccs) thing_inside
 230   = do  { (group', (groups', thing))
 231                 <- tc_group top_lvl sig_fn prag_fn scc $
 232                    tc_val_binds top_lvl sig_fn prag_fn sccs thing_inside
 233         ; return (group' ++ groups', thing) }
 234
 235 ------------------------
 236 tc_group :: TopLevelFlag -> TcSigFun -> TcPragFun
 237          -> SCC (LHsBind Name) -> TcM thing
 238          -> TcM ([(RecFlag, LHsBinds TcId)], thing)
 239
 240 -- Typecheck one strongly-connected component of the original program.
 241 -- We get a list of groups back, because there may
 242 -- be specialisations etc as well
 243
 244 tc_group top_lvl sig_fn prag_fn scc@(AcyclicSCC bind) thing_inside
 245   =     -- A single non-recursive binding
 246         -- We want to keep non-recursive things non-recursive
 247         -- so that we desugar unlifted bindings correctly
 248     do  { (binds, thing) <- tcPolyBinds top_lvl NonRecursive
 249                                         sig_fn prag_fn scc thing_inside
 250         ; return ([(NonRecursive, b) | b <- binds], thing) }
 251
 252 tc_group top_lvl sig_fn prag_fn scc@(CyclicSCC binds) thing_inside
 253   =     -- A recursive strongly-connected component
 254         -- To maximise polymorphism (with -fglasgow-exts), we do a new
 255         -- strongly-connected  component analysis, this time omitting
 256         -- any references to variables with type signatures.
 257         --
 258         -- Then we bring into scope all the variables with type signatures
 259     do  { traceTc (text "tc_group rec" <+> vcat [ppr b $$ text "--and--" | b <- binds])
 260         ; gla_exts     <- doptM Opt_GlasgowExts
 261         ; (binds,thing) <- if gla_exts
 262                            then go new_sccs
 263                            else go1 scc thing_inside
 264         ; return ([(Recursive, unionManyBags binds)], thing) }
 265                 -- Rec them all together
 266   where
 267     new_sccs :: [SCC (LHsBind Name)]
 268     new_sccs = stronglyConnComp (mkEdges has_sig binds)
 269
 270 --  go :: SCC (LHsBind Name) -> TcM ([LHsBind TcId], thing)
 271     go (scc:sccs) = do  { (binds1, (binds2, thing)) <- go1 scc (go sccs)
 272                         ; return (binds1 ++ binds2, thing) }
 273     go []         = do  { thing <- thing_inside; return ([], thing) }
 274
 275     go1 scc thing_inside = tcPolyBinds top_lvl Recursive
 276                                 sig_fn prag_fn scc thing_inside
 277
 278     has_sig :: Name -> Bool
 279     has_sig n = isJust (sig_fn n)
 280
 281 ------------------------
 282 tcPolyBinds :: TopLevelFlag -> RecFlag
 283             -> TcSigFun -> TcPragFun
 284             -> SCC (LHsBind Name)
 285             -> TcM thing
 286             -> TcM ([LHsBinds TcId], thing)
 287
 288 -- Typechecks a single bunch of bindings all together,
 289 -- and generalises them.  The bunch may be only part of a recursive
 290 -- group, because we use type signatures to maximise polymorphism
 291 --
 292 -- Deals with the bindInstsOfLocalFuns thing too
 293 --
 294 -- Returns a list because the input may be a single non-recursive binding,
 295 -- in which case the dependency order of the resulting bindings is
 296 -- important.
 297
 298 tcPolyBinds top_lvl is_rec sig_fn prag_fn scc thing_inside
 299   =     -- NB: polymorphic recursion means that a function
 300         -- may use an instance of itself, we must look at the LIE arising
 301         -- from the function's own right hand side.  Hence the getLIE
 302         -- encloses the tc_poly_binds.
 303      do { traceTc (text "tcPolyBinds" <+> ppr scc)
 304         ; ((binds1, poly_ids, thing), lie) <- getLIE $
 305                 do { (binds1, poly_ids) <- tc_poly_binds top_lvl is_rec
 306                                                          sig_fn prag_fn scc
 307                    ; thing <- tcExtendIdEnv poly_ids thing_inside
 308                    ; return (binds1, poly_ids, thing) }
 309
 310         ; if isTopLevel top_lvl
 311           then          -- For the top level don't bother will all this
 312                         -- bindInstsOfLocalFuns stuff. All the top level
 313                         -- things are rec'd together anyway, so it's fine to
 314                         -- leave them to the tcSimplifyTop,
 315                         -- and quite a bit faster too
 316                 do { extendLIEs lie; return (binds1, thing) }
 317
 318           else do       -- Nested case
 319                 { lie_binds <- bindInstsOfLocalFuns lie poly_ids
 320                 ; return (binds1 ++ [lie_binds], thing) }}
 321
 322 ------------------------
 323 tc_poly_binds :: TopLevelFlag -> RecFlag
 324               -> TcSigFun -> TcPragFun
 325               -> SCC (LHsBind Name)
 326               -> TcM ([LHsBinds TcId], [TcId])
 327 -- Typechecks the bindings themselves
 328 -- Knows nothing about the scope of the bindings
 329
 330 tc_poly_binds top_lvl is_rec sig_fn prag_fn bind_scc
 331   = let
 332         non_rec      = case bind_scc of { AcyclicSCC _ -> True; CyclicSCC _ -> False }
 333         binds        = flattenSCC bind_scc
 334         binder_names = collectHsBindBinders (listToBag binds)
 335
 336         loc = getLoc (head binds)
 337                 -- TODO: location a bit awkward, but the mbinds have been
 338                 --       dependency analysed and may no longer be adjacent
 339     in
 340         -- SET UP THE MAIN RECOVERY; take advantage of any type sigs
 341     setSrcSpan loc                              $
 342     recoverM (recoveryCode binder_names sig_fn) $ do
 343
 344   { traceTc (ptext SLIT("------------------------------------------------"))
 345   ; traceTc (ptext SLIT("Bindings for") <+> ppr binder_names)
 346
 347         -- TYPECHECK THE BINDINGS
 348   ; ((binds', mono_bind_infos), lie_req)
 349         <- getLIE (tcMonoBinds binds sig_fn non_rec)
 350
 351         -- CHECK FOR UNLIFTED BINDINGS
 352         -- These must be non-recursive etc, and are not generalised
 353         -- They desugar to a case expression in the end
 354   ; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos)
 355   ; if any isUnLiftedType zonked_mono_tys then
 356     do  {       -- Unlifted bindings
 357           checkUnliftedBinds top_lvl is_rec binds' mono_bind_infos
 358         ; extendLIEs lie_req
 359         ; let exports  = zipWith mk_export mono_bind_infos zonked_mono_tys
 360               mk_export (name, Nothing,  mono_id) mono_ty = ([], mkLocalId name mono_ty, mono_id, [])
 361               mk_export (name, Just sig, mono_id) mono_ty = ([], sig_id sig,             mono_id, [])
 362                         -- ToDo: prags
 363
 364         ; return ( [unitBag $ L loc $ AbsBinds [] [] exports binds'],
 365                    [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked
 366
 367     else do     -- The normal lifted case: GENERALISE
 368   { is_unres <- isUnRestrictedGroup binds sig_fn
 369   ; (tyvars_to_gen, dict_binds, dict_ids)
 370         <- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
 371            generalise top_lvl is_unres mono_bind_infos lie_req
 372
 373         -- FINALISE THE QUANTIFIED TYPE VARIABLES
 374         -- The quantified type variables often include meta type variables
 375         -- we want to freeze them into ordinary type variables, and
 376         -- default their kind (e.g. from OpenTypeKind to TypeKind)
 377   ; tyvars_to_gen' <- mappM zonkQuantifiedTyVar tyvars_to_gen
 378
 379         -- BUILD THE POLYMORPHIC RESULT IDs
 380   ; exports <- mapM (mkExport prag_fn tyvars_to_gen' (map idType dict_ids))
 381                     mono_bind_infos
 382
 383         -- ZONK THE poly_ids, because they are used to extend the type
 384         -- environment; see the invariant on TcEnv.tcExtendIdEnv
 385   ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
 386   ; zonked_poly_ids <- mappM zonkId poly_ids
 387
 388   ; traceTc (text "binding:" <+> ppr ((dict_ids, dict_binds),
 389                                       map idType zonked_poly_ids))
 390
 391   ; let abs_bind = L loc $ AbsBinds tyvars_to_gen'
 392                                     dict_ids exports
 393                                     (dict_binds `unionBags` binds')
 394
 395   ; return ([unitBag abs_bind], zonked_poly_ids)
 396   } }
 397
 398
 399 --------------
 400 mkExport :: TcPragFun -> [TyVar] -> [TcType] -> MonoBindInfo
 401          -> TcM ([TyVar], Id, Id, [Prag])
 402 mkExport prag_fn inferred_tvs dict_tys (poly_name, mb_sig, mono_id)
 403   = do  { prags <- tcPrags poly_id (prag_fn poly_name)
 404         ; return (tvs, poly_id, mono_id, prags) }
 405   where
 406     (tvs, poly_id) = case mb_sig of
 407                         Just sig -> (sig_tvs sig,  sig_id sig)
 408                         Nothing  -> (inferred_tvs, mkLocalId poly_name poly_ty)
 409                    where
 410                      poly_ty = mkForAllTys inferred_tvs
 411                                $ mkFunTys dict_tys
 412                                $ idType mono_id
 413
 414 ------------------------
 415 type TcPragFun = Name -> [LSig Name]
 416
 417 mkPragFun :: [LSig Name] -> TcPragFun
 418 mkPragFun sigs = \n -> lookupNameEnv env n `orElse` []
 419         where
 420           prs = [(fromJust (sigName sig), sig) | sig <- sigs, isPragLSig sig]
 421           env = foldl add emptyNameEnv prs
 422           add env (n,p) = extendNameEnv_Acc (:) singleton env n p
 423
 424 tcPrags :: Id -> [LSig Name] -> TcM [Prag]
 425 tcPrags poly_id prags = mapM tc_prag prags
 426   where
 427     tc_prag (L loc prag) = setSrcSpan loc $
 428                            addErrCtxt (pragSigCtxt prag) $
 429                            tcPrag poly_id prag
 430
 431 pragSigCtxt prag = hang (ptext SLIT("In the pragma")) 2 (ppr prag)
 432
 433 tcPrag :: TcId -> Sig Name -> TcM Prag
 434 tcPrag poly_id (SpecSig orig_name hs_ty) = tcSpecPrag poly_id hs_ty
 435 tcPrag poly_id (SpecInstSig hs_ty)       = tcSpecPrag poly_id hs_ty
 436 tcPrag poly_id (InlineSig inl _ act)     = return (InlinePrag inl act)
 437
 438
 439 tcSpecPrag :: TcId -> LHsType Name -> TcM Prag
 440 tcSpecPrag poly_id hs_ty
 441   = do  { spec_ty <- tcHsSigType (FunSigCtxt (idName poly_id)) hs_ty
 442         ; (co_fn, lie)   <- getLIE (tcSub spec_ty (idType poly_id))
 443         ; extendLIEs lie
 444         ; let const_dicts = map instToId lie
 445         ; return (SpecPrag (co_fn <$> (HsVar poly_id)) spec_ty const_dicts) }
 446
 447 --------------
 448 -- If typechecking the binds fails, then return with each
 449 -- signature-less binder given type (forall a.a), to minimise
 450 -- subsequent error messages
 451 recoveryCode binder_names sig_fn
 452   = do  { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names)
 453         ; return ([], poly_ids) }
 454   where
 455     forall_a_a    = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
 456     poly_ids      = map mk_dummy binder_names
 457     mk_dummy name = case sig_fn name of
 458                       Just sig -> sig_id sig                    -- Signature
 459                       Nothing  -> mkLocalId name forall_a_a     -- No signature
 460
 461 -- Check that non-overloaded unlifted bindings are
 462 --      a) non-recursive,
 463 --      b) not top level,
 464 --      c) not a multiple-binding group (more or less implied by (a))
 465
 466 checkUnliftedBinds :: TopLevelFlag -> RecFlag
 467                    -> LHsBinds TcId -> [MonoBindInfo] -> TcM ()
 468 checkUnliftedBinds top_lvl is_rec mbind infos
 469   = do  { checkTc (isNotTopLevel top_lvl)
 470                   (unliftedBindErr "Top-level" mbind)
 471         ; checkTc (isNonRec is_rec)
 472                   (unliftedBindErr "Recursive" mbind)
 473         ; checkTc (isSingletonBag mbind)
 474                   (unliftedBindErr "Multiple" mbind)
 475         ; mapM_ check_sig infos }
 476   where
 477     check_sig (_, Just sig, _) = checkTc (null (sig_tvs sig) && null (sig_theta sig))
 478                                          (badUnliftedSig sig)
 479     check_sig other            = return ()
 480 \end{code}
 481
 482
 483 %************************************************************************
 484 %*                                                                      *
 485 \subsection{tcMonoBind}
 486 %*                                                                      *
 487 %************************************************************************
 488
 489 @tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.
 490 The signatures have been dealt with already.
 491
 492 \begin{code}
 493 tcMonoBinds :: [LHsBind Name]
 494             -> TcSigFun
 495             -> Bool     -- True <=> either the binders are not mentioned
 496                         --          in their RHSs or they have type sigs
 497             -> TcM (LHsBinds TcId, [MonoBindInfo])
 498
 499 tcMonoBinds [L b_loc (FunBind (L nm_loc name) inf matches fvs)]
 500             sig_fn              -- Single function binding,
 501             True                -- binder isn't mentioned in RHS,
 502   | Nothing <- sig_fn name      -- ...with no type signature
 503   =     -- In this very special case we infer the type of the
 504         -- right hand side first (it may have a higher-rank type)
 505         -- and *then* make the monomorphic Id for the LHS
 506         -- e.g.         f = \(x::forall a. a->a) -> <body>
 507         --      We want to infer a higher-rank type for f
 508     setSrcSpan b_loc    $
 509     do  { (matches', rhs_ty) <- tcInfer (tcMatchesFun name matches)
 510
 511                 -- Check for an unboxed tuple type
 512                 --      f = (# True, False #)
 513                 -- Zonk first just in case it's hidden inside a meta type variable
 514                 -- (This shows up as a (more obscure) kind error
 515                 --  in the 'otherwise' case of tcMonoBinds.)
 516         ; zonked_rhs_ty <- zonkTcType rhs_ty
 517         ; checkTc (not (isUnboxedTupleType zonked_rhs_ty))
 518                   (unboxedTupleErr name zonked_rhs_ty)
 519
 520         ; mono_name <- newLocalName name
 521         ; let mono_id = mkLocalId mono_name zonked_rhs_ty
 522         ; return (unitBag (L b_loc (FunBind (L nm_loc mono_id) inf matches' fvs)),
 523                   [(name, Nothing, mono_id)]) }
 524
 525 tcMonoBinds binds sig_fn non_rec
 526   = do  { tc_binds <- mapM (wrapLocM (tcLhs sig_fn)) binds
 527
 528         -- Bring (a) the scoped type variables, and (b) the Ids, into scope for the RHSs
 529         -- For (a) it's ok to bring them all into scope at once, even
 530         -- though each type sig should scope only over its own RHS,
 531         -- because the renamer has sorted all that out.
 532         ; let mono_info  = getMonoBindInfo tc_binds
 533               rhs_tvs    = [ (name, mkTyVarTy tv)
 534                            | (_, Just sig, _) <- mono_info,
 535                              (name, tv) <- sig_scoped sig `zip` sig_tvs sig ]
 536               rhs_id_env = map mk mono_info     -- A binding for each term variable
 537
 538         ; binds' <- tcExtendTyVarEnv2 rhs_tvs   $
 539                     tcExtendIdEnv2   rhs_id_env $
 540                     traceTc (text "tcMonoBinds" <+> vcat [ ppr n <+> ppr id <+> ppr (idType id)
 541                                                          | (n,id) <- rhs_id_env]) `thenM_`
 542                     mapM (wrapLocM tcRhs) tc_binds
 543         ; return (listToBag binds', mono_info) }
 544    where
 545     mk (name, Just sig, _)       = (name, sig_id sig)   -- Use the type sig if there is one
 546     mk (name, Nothing,  mono_id) = (name, mono_id)      -- otherwise use a monomorphic version
 547
 548 ------------------------
 549 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
 550 -- we typecheck the RHSs.  Basically what we are doing is this: for each binder:
 551 --      if there's a signature for it, use the instantiated signature type
 552 --      otherwise invent a type variable
 553 -- You see that quite directly in the FunBind case.
 554 --
 555 -- But there's a complication for pattern bindings:
 556 --      data T = MkT (forall a. a->a)
 557 --      MkT f = e
 558 -- Here we can guess a type variable for the entire LHS (which will be refined to T)
 559 -- but we want to get (f::forall a. a->a) as the RHS environment.
 560 -- The simplest way to do this is to typecheck the pattern, and then look up the
 561 -- bound mono-ids.  Then we want to retain the typechecked pattern to avoid re-doing
 562 -- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't
 563
 564 data TcMonoBind         -- Half completed; LHS done, RHS not done
 565   = TcFunBind  MonoBindInfo  (Located TcId) Bool (MatchGroup Name)
 566   | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name) TcSigmaType
 567
 568 type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
 569         -- Type signature (if any), and
 570         -- the monomorphic bound things
 571
 572 bndrNames :: [MonoBindInfo] -> [Name]
 573 bndrNames mbi = [n | (n,_,_) <- mbi]
 574
 575 getMonoType :: MonoBindInfo -> TcTauType
 576 getMonoType (_,_,mono_id) = idType mono_id
 577
 578 tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind
 579 tcLhs sig_fn (FunBind (L nm_loc name) inf matches _)
 580   = do  { let mb_sig = sig_fn name
 581         ; mono_name <- newLocalName name
 582         ; mono_ty   <- mk_mono_ty mb_sig
 583         ; let mono_id = mkLocalId mono_name mono_ty
 584         ; return (TcFunBind (name, mb_sig, mono_id) (L nm_loc mono_id) inf matches) }
 585   where
 586     mk_mono_ty (Just sig) = return (sig_tau sig)
 587     mk_mono_ty Nothing    = newTyFlexiVarTy argTypeKind
 588
 589 tcLhs sig_fn bind@(PatBind pat grhss _ _)
 590   = do  { let tc_pat exp_ty = tcPat (LetPat sig_fn) pat exp_ty lookup_infos
 591         ; ((pat', ex_tvs, infos), pat_ty)
 592                 <- addErrCtxt (patMonoBindsCtxt pat grhss)
 593                               (tcInfer tc_pat)
 594
 595         -- Don't know how to deal with pattern-bound existentials yet
 596         ; checkTc (null ex_tvs) (existentialExplode bind)
 597
 598         ; return (TcPatBind infos pat' grhss pat_ty) }
 599   where
 600     names = collectPatBinders pat
 601
 602         -- After typechecking the pattern, look up the binder
 603         -- names, which the pattern has brought into scope.
 604     lookup_infos :: TcM [MonoBindInfo]
 605     lookup_infos = do { mono_ids <- tcLookupLocalIds names
 606                       ; return [ (name, sig_fn name, mono_id)
 607                                | (name, mono_id) <- names `zip` mono_ids] }
 608
 609 tcLhs sig_fn other_bind = pprPanic "tcLhs" (ppr other_bind)
 610         -- AbsBind, VarBind impossible
 611
 612 -------------------
 613 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
 614 tcRhs (TcFunBind info fun'@(L _ mono_id) inf matches)
 615   = do  { matches' <- tcMatchesFun (idName mono_id) matches
 616                                    (Check (idType mono_id))
 617         ; return (FunBind fun' inf matches' placeHolderNames) }
 618
 619 tcRhs bind@(TcPatBind _ pat' grhss pat_ty)
 620   = do  { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
 621                     tcGRHSsPat grhss (Check pat_ty)
 622         ; return (PatBind pat' grhss' pat_ty placeHolderNames) }
 623
 624
 625 ---------------------
 626 getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]
 627 getMonoBindInfo tc_binds
 628   = foldr (get_info . unLoc) [] tc_binds
 629   where
 630     get_info (TcFunBind info _ _ _)  rest = info : rest
 631     get_info (TcPatBind infos _ _ _) rest = infos ++ rest
 632 \end{code}
 633
 634
 635 %************************************************************************
 636 %*                                                                      *
 637                 Generalisation
 638 %*                                                                      *
 639 %************************************************************************
 640
 641 \begin{code}
 642 generalise :: TopLevelFlag -> Bool
 643            -> [MonoBindInfo] -> [Inst]
 644            -> TcM ([TcTyVar], TcDictBinds, [TcId])
 645 generalise top_lvl is_unrestricted mono_infos lie_req
 646   | not is_unrestricted -- RESTRICTED CASE
 647   =     -- Check signature contexts are empty
 648     do  { checkTc (all is_mono_sig sigs)
 649                   (restrictedBindCtxtErr bndrs)
 650
 651         -- Now simplify with exactly that set of tyvars
 652         -- We have to squash those Methods
 653         ; (qtvs, binds) <- tcSimplifyRestricted doc top_lvl bndrs
 654                                                 tau_tvs lie_req
 655
 656         -- Check that signature type variables are OK
 657         ; final_qtvs <- checkSigsTyVars qtvs sigs
 658
 659         ; return (final_qtvs, binds, []) }
 660
 661   | null sigs   -- UNRESTRICTED CASE, NO TYPE SIGS
 662   = tcSimplifyInfer doc tau_tvs lie_req
 663
 664   | otherwise   -- UNRESTRICTED CASE, WITH TYPE SIGS
 665   = do  { sig_lie <- unifyCtxts sigs    -- sigs is non-empty
 666         ; let   -- The "sig_avails" is the stuff available.  We get that from
 667                 -- the context of the type signature, BUT ALSO the lie_avail
 668                 -- so that polymorphic recursion works right (see Note [Polymorphic recursion])
 669                 local_meths = [mkMethInst sig mono_id | (_, Just sig, mono_id) <- mono_infos]
 670                 sig_avails = sig_lie ++ local_meths
 671
 672         -- Check that the needed dicts can be
 673         -- expressed in terms of the signature ones
 674         ; (forall_tvs, dict_binds) <- tcSimplifyInferCheck doc tau_tvs sig_avails lie_req
 675
 676         -- Check that signature type variables are OK
 677         ; final_qtvs <- checkSigsTyVars forall_tvs sigs
 678
 679         ; returnM (final_qtvs, dict_binds, map instToId sig_lie) }
 680   where
 681     bndrs   = bndrNames mono_infos
 682     sigs    = [sig | (_, Just sig, _) <- mono_infos]
 683     tau_tvs = foldr (unionVarSet . tyVarsOfType . getMonoType) emptyVarSet mono_infos
 684     is_mono_sig sig = null (sig_theta sig)
 685     doc = ptext SLIT("type signature(s) for") <+> pprBinders bndrs
 686
 687     mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs,
 688                             sig_theta = theta, sig_tau = tau, sig_loc = loc }) mono_id
 689       = Method mono_id poly_id (mkTyVarTys tvs) theta tau loc
 690
 691
 692 -- Check that all the signature contexts are the same
 693 -- The type signatures on a mutually-recursive group of definitions
 694 -- must all have the same context (or none).
 695 --
 696 -- The trick here is that all the signatures should have the same
 697 -- context, and we want to share type variables for that context, so that
 698 -- all the right hand sides agree a common vocabulary for their type
 699 -- constraints
 700 --
 701 -- We unify them because, with polymorphic recursion, their types
 702 -- might not otherwise be related.  This is a rather subtle issue.
 703 unifyCtxts :: [TcSigInfo] -> TcM [Inst]
 704 unifyCtxts (sig1 : sigs)        -- Argument is always non-empty
 705   = do  { mapM unify_ctxt sigs
 706         ; newDictsAtLoc (sig_loc sig1) (sig_theta sig1) }
 707   where
 708     theta1 = sig_theta sig1
 709     unify_ctxt :: TcSigInfo -> TcM ()
 710     unify_ctxt sig@(TcSigInfo { sig_theta = theta })
 711         = setSrcSpan (instLocSrcSpan (sig_loc sig))     $
 712           addErrCtxt (sigContextsCtxt sig1 sig)         $
 713           unifyTheta theta1 theta
 714
 715 checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
 716 checkSigsTyVars qtvs sigs
 717   = do  { gbl_tvs <- tcGetGlobalTyVars
 718         ; sig_tvs_s <- mappM (check_sig gbl_tvs) sigs
 719
 720         ; let   -- Sigh.  Make sure that all the tyvars in the type sigs
 721                 -- appear in the returned ty var list, which is what we are
 722                 -- going to generalise over.  Reason: we occasionally get
 723                 -- silly types like
 724                 --      type T a = () -> ()
 725                 --      f :: T a
 726                 --      f () = ()
 727                 -- Here, 'a' won't appear in qtvs, so we have to add it
 728                 sig_tvs = foldl extendVarSetList emptyVarSet sig_tvs_s
 729                 all_tvs = varSetElems (extendVarSetList sig_tvs qtvs)
 730         ; returnM all_tvs }
 731   where
 732     check_sig gbl_tvs (TcSigInfo {sig_id = id, sig_tvs = tvs,
 733                                   sig_theta = theta, sig_tau = tau})
 734       = addErrCtxt (ptext SLIT("In the type signature for") <+> quotes (ppr id))        $
 735         addErrCtxtM (sigCtxt id tvs theta tau)                                          $
 736         do { tvs' <- checkDistinctTyVars tvs
 737            ; ifM (any (`elemVarSet` gbl_tvs) tvs')
 738                  (bleatEscapedTvs gbl_tvs tvs tvs')
 739            ; return tvs' }
 740
 741 checkDistinctTyVars :: [TcTyVar] -> TcM [TcTyVar]
 742 -- (checkDistinctTyVars tvs) checks that the tvs from one type signature
 743 -- are still all type variables, and all distinct from each other.
 744 -- It returns a zonked set of type variables.
 745 -- For example, if the type sig is
 746 --      f :: forall a b. a -> b -> b
 747 -- we want to check that 'a' and 'b' haven't
 748 --      (a) been unified with a non-tyvar type
 749 --      (b) been unified with each other (all distinct)
 750
 751 checkDistinctTyVars sig_tvs
 752   = do  { zonked_tvs <- mapM zonk_one sig_tvs
 753         ; foldlM check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs)
 754         ; return zonked_tvs }
 755   where
 756     zonk_one sig_tv = do { ty <- zonkTcTyVar sig_tv
 757                          ; return (tcGetTyVar "checkDistinctTyVars" ty) }
 758         -- 'ty' is bound to be a type variable, because SigSkolTvs
 759         -- can only be unified with type variables
 760
 761     check_dup :: TyVarEnv TcTyVar -> (TcTyVar, TcTyVar) -> TcM (TyVarEnv TcTyVar)
 762         -- The TyVarEnv maps each zonked type variable back to its
 763         -- corresponding user-written signature type variable
 764     check_dup acc (sig_tv, zonked_tv)
 765         = case lookupVarEnv acc zonked_tv of
 766                 Just sig_tv' -> bomb_out sig_tv sig_tv'
 767
 768                 Nothing -> return (extendVarEnv acc zonked_tv sig_tv)
 769
 770     bomb_out sig_tv1 sig_tv2
 771        = failWithTc (ptext SLIT("Quantified type variable") <+> quotes (ppr tidy_tv1)
 772                      <+> ptext SLIT("is unified with another quantified type variable")
 773                      <+> quotes (ppr tidy_tv2))
 774        where
 775          (env1,  tidy_tv1) = tidyOpenTyVar emptyTidyEnv sig_tv1
 776          (_env2, tidy_tv2) = tidyOpenTyVar env1         sig_tv2
 777 \end{code}
 778
 779
 780 @getTyVarsToGen@ decides what type variables to generalise over.
 781
 782 For a "restricted group" -- see the monomorphism restriction
 783 for a definition -- we bind no dictionaries, and
 784 remove from tyvars_to_gen any constrained type variables
 785
 786 *Don't* simplify dicts at this point, because we aren't going
 787 to generalise over these dicts.  By the time we do simplify them
 788 we may well know more.  For example (this actually came up)
 789         f :: Array Int Int
 790         f x = array ... xs where xs = [1,2,3,4,5]
 791 We don't want to generate lots of (fromInt Int 1), (fromInt Int 2)
 792 stuff.  If we simplify only at the f-binding (not the xs-binding)
 793 we'll know that the literals are all Ints, and we can just produce
 794 Int literals!
 795
 796 Find all the type variables involved in overloading, the
 797 "constrained_tyvars".  These are the ones we *aren't* going to
 798 generalise.  We must be careful about doing this:
 799
 800  (a) If we fail to generalise a tyvar which is not actually
 801         constrained, then it will never, ever get bound, and lands
 802         up printed out in interface files!  Notorious example:
 803                 instance Eq a => Eq (Foo a b) where ..
 804         Here, b is not constrained, even though it looks as if it is.
 805         Another, more common, example is when there's a Method inst in
 806         the LIE, whose type might very well involve non-overloaded
 807         type variables.
 808   [NOTE: Jan 2001: I don't understand the problem here so I'm doing
 809         the simple thing instead]
 810
 811  (b) On the other hand, we mustn't generalise tyvars which are constrained,
 812         because we are going to pass on out the unmodified LIE, with those
 813         tyvars in it.  They won't be in scope if we've generalised them.
 814
 815 So we are careful, and do a complete simplification just to find the
 816 constrained tyvars. We don't use any of the results, except to
 817 find which tyvars are constrained.
 818
 819 Note [Polymorphic recursion]
 820 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 821 The game plan for polymorphic recursion in the code above is
 822
 823         * Bind any variable for which we have a type signature
 824           to an Id with a polymorphic type.  Then when type-checking
 825           the RHSs we'll make a full polymorphic call.
 826
 827 This fine, but if you aren't a bit careful you end up with a horrendous
 828 amount of partial application and (worse) a huge space leak. For example:
 829
 830         f :: Eq a => [a] -> [a]
 831         f xs = ...f...
 832
 833 If we don't take care, after typechecking we get
 834
 835         f = /\a -> \d::Eq a -> let f' = f a d
 836                                in
 837                                \ys:[a] -> ...f'...
 838
 839 Notice the the stupid construction of (f a d), which is of course
 840 identical to the function we're executing.  In this case, the
 841 polymorphic recursion isn't being used (but that's a very common case).
 842 We'd prefer
 843
 844         f = /\a -> \d::Eq a -> letrec
 845                                  fm = \ys:[a] -> ...fm...
 846                                in
 847                                fm
 848
 849 This can lead to a massive space leak, from the following top-level defn
 850 (post-typechecking)
 851
 852         ff :: [Int] -> [Int]
 853         ff = f Int dEqInt
 854
 855 Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but
 856 f' is another thunk which evaluates to the same thing... and you end
 857 up with a chain of identical values all hung onto by the CAF ff.
 858
 859         ff = f Int dEqInt
 860
 861            = let f' = f Int dEqInt in \ys. ...f'...
 862
 863            = let f' = let f' = f Int dEqInt in \ys. ...f'...
 864                       in \ys. ...f'...
 865
 866 Etc.
 867 Solution: when typechecking the RHSs we always have in hand the
 868 *monomorphic* Ids for each binding.  So we just need to make sure that
 869 if (Method f a d) shows up in the constraints emerging from (...f...)
 870 we just use the monomorphic Id.  We achieve this by adding monomorphic Ids
 871 to the "givens" when simplifying constraints.  That's what the "lies_avail"
 872 is doing.
 873
 874
 875 %************************************************************************
 876 %*                                                                      *
 877                 Signatures
 878 %*                                                                      *
 879 %************************************************************************
 880
 881 Type signatures are tricky.  See Note [Signature skolems] in TcType
 882
 883 \begin{code}
 884 tcTySigs :: [LSig Name] -> TcM [TcSigInfo]
 885 tcTySigs sigs = do { mb_sigs <- mappM tcTySig (filter isVanillaLSig sigs)
 886                    ; return (catMaybes mb_sigs) }
 887
 888 tcTySig :: LSig Name -> TcM (Maybe TcSigInfo)
 889 tcTySig (L span (Sig (L _ name) ty))
 890   = recoverM (return Nothing)   $
 891     setSrcSpan span             $
 892     do  { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
 893         ; (tvs, theta, tau) <- tcInstSigType name scoped_names sigma_ty
 894         ; loc <- getInstLoc (SigOrigin (SigSkol name))
 895         ; return (Just (TcSigInfo { sig_id = mkLocalId name sigma_ty,
 896                                     sig_tvs = tvs, sig_theta = theta, sig_tau = tau,
 897                                     sig_scoped = scoped_names, sig_loc = loc })) }
 898   where
 899         -- The scoped names are the ones explicitly mentioned
 900         -- in the HsForAll.  (There may be more in sigma_ty, because
 901         -- of nested type synonyms.  See Note [Scoped] with TcSigInfo.)
 902     scoped_names = case ty of
 903                         L _ (HsForAllTy Explicit tvs _ _) -> hsLTyVarNames tvs
 904                         other                             -> []
 905
 906 isUnRestrictedGroup :: [LHsBind Name] -> TcSigFun -> TcM Bool
 907 isUnRestrictedGroup binds sig_fn
 908   = do  { mono_restriction <- doptM Opt_MonomorphismRestriction
 909         ; return (not mono_restriction || all_unrestricted) }
 910   where
 911     all_unrestricted = all (unrestricted . unLoc) binds
 912     has_sig n = isJust (sig_fn n)
 913
 914     unrestricted (PatBind other _ _ _)   = False
 915     unrestricted (VarBind v _)           = has_sig v
 916     unrestricted (FunBind v _ matches _) = unrestricted_match matches
 917                                          || has_sig (unLoc v)
 918
 919     unrestricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = False
 920         -- No args => like a pattern binding
 921     unrestricted_match other              = True
 922         -- Some args => a function binding
 923 \end{code}
 924
 925
 926 %************************************************************************
 927 %*                                                                      *
 928 \subsection[TcBinds-errors]{Error contexts and messages}
 929 %*                                                                      *
 930 %************************************************************************
 931
 932
 933 \begin{code}
 934 -- This one is called on LHS, when pat and grhss are both Name
 935 -- and on RHS, when pat is TcId and grhss is still Name
 936 patMonoBindsCtxt pat grhss
 937   = hang (ptext SLIT("In a pattern binding:")) 4 (pprPatBind pat grhss)
 938
 939 -----------------------------------------------
 940 sigContextsCtxt sig1 sig2
 941   = vcat [ptext SLIT("When matching the contexts of the signatures for"),
 942           nest 2 (vcat [ppr id1 <+> dcolon <+> ppr (idType id1),
 943                         ppr id2 <+> dcolon <+> ppr (idType id2)]),
 944           ptext SLIT("The signature contexts in a mutually recursive group should all be identical")]
 945   where
 946     id1 = sig_id sig1
 947     id2 = sig_id sig2
 948
 949
 950 -----------------------------------------------
 951 unliftedBindErr flavour mbind
 952   = hang (text flavour <+> ptext SLIT("bindings for unlifted types aren't allowed:"))
 953          4 (ppr mbind)
 954
 955 badUnliftedSig sig
 956   = hang (ptext SLIT("Illegal polymorphic signature in an unlifted binding"))
 957          4 (ppr sig)
 958
 959 -----------------------------------------------
 960 unboxedTupleErr name ty
 961   = hang (ptext SLIT("Illegal binding of unboxed tuple"))
 962          4 (ppr name <+> dcolon <+> ppr ty)
 963
 964 -----------------------------------------------
 965 existentialExplode mbinds
 966   = hang (vcat [text "My brain just exploded.",
 967                 text "I can't handle pattern bindings for existentially-quantified constructors.",
 968                 text "In the binding group"])
 969         4 (ppr mbinds)
 970
 971 -----------------------------------------------
 972 restrictedBindCtxtErr binder_names
 973   = hang (ptext SLIT("Illegal overloaded type signature(s)"))
 974        4 (vcat [ptext SLIT("in a binding group for") <+> pprBinders binder_names,
 975                 ptext SLIT("that falls under the monomorphism restriction")])
 976
 977 genCtxt binder_names
 978   = ptext SLIT("When generalising the type(s) for") <+> pprBinders binder_names
 979 \end{code}