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