ghc/compiler/typecheck/TcSimplify.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcSimplify]{TcSimplify}
   5
   6 Notes:
   7
   8 Inference (local definitions)
   9 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  10 If the inst constrains a local type variable, then
  11   [ReduceMe] if it's a literal or method inst, reduce it
  12
  13   [DontReduce] otherwise see whether the inst is just a constant
  14     if succeed, use it
  15     if not, add original to context
  16   This check gets rid of constant dictionaries without
  17   losing sharing.
  18
  19 If the inst does not constrain a local type variable then
  20   [Free] then throw it out as free.
  21
  22 Inference (top level definitions)
  23 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  24 If the inst does not constrain a local type variable, then
  25   [FreeIfTautological] try for tautology;
  26       if so, throw it out as free
  27          (discarding result of tautology check)
  28       if not, make original inst part of the context
  29          (eliminating superclasses as usual)
  30
  31 If the inst constrains a local type variable, then
  32    as for inference (local defns)
  33
  34
  35 Checking (local defns)
  36 ~~~~~~~~
  37 If the inst constrains a local type variable then
  38   [ReduceMe] reduce (signal error on failure)
  39
  40 If the inst does not constrain a local type variable then
  41   [Free] throw it out as free.
  42
  43 Checking (top level)
  44 ~~~~~~~~~~~~~~~~~~~~
  45 If the inst constrains a local type variable then
  46    as for checking (local defns)
  47
  48 If the inst does not constrain a local type variable then
  49    as for checking (local defns)
  50
  51
  52
  53 Checking once per module
  54 ~~~~~~~~~~~~~~~~~~~~~~~~~
  55 For dicts of the form (C a), where C is a std class
  56   and "a" is a type variable,
  57   [DontReduce] add to context
  58
  59 otherwise [ReduceMe] always reduce
  60
  61 [NB: we may generate one Tree [Int] dict per module, so
  62      sharing is not complete.]
  63
  64 Sort out ambiguity at the end.
  65
  66 Principal types
  67 ~~~~~~~~~~~~~~~
  68 class C a where
  69   op :: a -> a
  70
  71 f x = let g y = op (y::Int) in True
  72
  73 Here the principal type of f is (forall a. a->a)
  74 but we'll produce the non-principal type
  75     f :: forall a. C Int => a -> a
  76
  77
  78 Ambiguity
  79 ~~~~~~~~~
  80 Consider this:
  81
  82         instance C (T a) Int  where ...
  83         instance C (T a) Bool where ...
  84
  85 and suppose we infer a context
  86
  87             C (T x) y
  88
  89 from some expression, where x and y are type varibles,
  90 and x is ambiguous, and y is being quantified over.
  91 Should we complain, or should we generate the type
  92
  93        forall x y. C (T x) y => <type not involving x>
  94
  95 The idea is that at the call of the function we might
  96 know that y is Int (say), so the "x" isn't really ambiguous.
  97 Notice that we have to add "x" to the type variables over
  98 which we generalise.
  99
 100 Something similar can happen even if C constrains only ambiguous
 101 variables.  Suppose we infer the context
 102
 103        C [x]
 104
 105 where x is ambiguous.  Then we could infer the type
 106
 107        forall x. C [x] => <type not involving x>
 108
 109 in the hope that at the call site there was an instance
 110 decl such as
 111
 112        instance Num a => C [a] where ...
 113
 114 and hence the default mechanism would resolve the "a".
 115
 116
 117 \begin{code}
 118 module TcSimplify (
 119         tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts,
 120         tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas,
 121         bindInstsOfLocalFuns
 122     ) where
 123
 124 #include "HsVersions.h"
 125
 126 import CmdLineOpts      ( opt_MaxContextReductionDepth, opt_GlasgowExts, opt_WarnTypeDefaults )
 127 import HsSyn            ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
 128 import TcHsSyn          ( TcExpr, TcId,
 129                           TcMonoBinds, TcDictBinds
 130                         )
 131
 132 import TcMonad
 133 import Inst             ( lookupInst, lookupSimpleInst, LookupInstResult(..),
 134                           tyVarsOfInst,
 135                           isDict, isStdClassTyVarDict, isMethodFor,
 136                           instToId, instBindingRequired, instCanBeGeneralised,
 137                           newDictFromOld,
 138                           getDictClassTys,
 139                           instLoc, pprInst, zonkInst, tidyInst, tidyInsts,
 140                           Inst, LIE, pprInsts, pprInstsInFull, mkLIE, emptyLIE,
 141                           plusLIE
 142                         )
 143 import TcEnv            ( tcGetGlobalTyVars )
 144 import TcType           ( TcType, TcTyVarSet, typeToTcType )
 145 import TcUnify          ( unifyTauTy )
 146 import Id               ( idType )
 147 import Bag              ( bagToList )
 148 import Class            ( Class, classBigSig, classInstEnv )
 149 import PrelInfo         ( isNumericClass, isCreturnableClass, isCcallishClass )
 150
 151 import Type             ( Type, ThetaType, TauType, mkTyVarTy, getTyVar,
 152                           isTyVarTy, splitSigmaTy, tyVarsOfTypes
 153                         )
 154 import InstEnv          ( InstEnv )
 155 import Subst            ( mkTopTyVarSubst, substTheta )
 156 import PprType          ( pprConstraint )
 157 import TysWiredIn       ( unitTy )
 158 import VarSet
 159 import FiniteMap
 160 import BasicTypes       ( TopLevelFlag(..) )
 161 import CmdLineOpts      ( opt_GlasgowExts )
 162 import Outputable
 163 import Util
 164 import List             ( partition )
 165 \end{code}
 166
 167
 168 %************************************************************************
 169 %*                                                                      *
 170 \subsection[tcSimplify-main]{Main entry function}
 171 %*                                                                      *
 172 %************************************************************************
 173
 174 The main wrapper is @tcSimplify@.  It just calls @tcSimpl@, but with
 175 the ``don't-squash-consts'' flag set depending on top-level ness.  For
 176 top level defns we *do* squash constants, so that they stay local to a
 177 single defn.  This makes things which are inlined more likely to be
 178 exportable, because their constants are "inside".  Later passes will
 179 float them out if poss, after inlinings are sorted out.
 180
 181 \begin{code}
 182 tcSimplify
 183         :: SDoc
 184         -> TopLevelFlag
 185         -> TcTyVarSet                   -- ``Local''  type variables
 186                                         -- ASSERT: this tyvar set is already zonked
 187         -> LIE                          -- Wanted
 188         -> TcM s (LIE,                  -- Free
 189                   TcDictBinds,          -- Bindings
 190                   LIE)                  -- Remaining wanteds; no dups
 191
 192 tcSimplify str top_lvl local_tvs wanted_lie
 193   | isEmptyVarSet local_tvs
 194   = returnTc (wanted_lie, EmptyMonoBinds, emptyLIE)
 195
 196   | otherwise
 197   = reduceContext str try_me [] wanteds         `thenTc` \ (binds, frees, irreds) ->
 198
 199         -- Check for non-generalisable insts
 200     let
 201         cant_generalise = filter (not . instCanBeGeneralised) irreds
 202     in
 203     checkTc (null cant_generalise)
 204             (genCantGenErr cant_generalise)     `thenTc_`
 205
 206         -- Check for ambiguous insts.
 207         -- You might think these can't happen (I did) because an ambiguous
 208         -- inst like (Eq a) will get tossed out with "frees", and eventually
 209         -- dealt with by tcSimplifyTop.
 210         -- But we can get stuck with
 211         --      C a b
 212         -- where "a" is one of the local_tvs, but "b" is unconstrained.
 213         -- Then we must yell about the ambiguous b
 214         -- But we must only do so if "b" really is unconstrained; so
 215         -- we must grab the global tyvars to answer that question
 216     tcGetGlobalTyVars                           `thenNF_Tc` \ global_tvs ->
 217     let
 218         avail_tvs           = local_tvs `unionVarSet` global_tvs
 219         (irreds', bad_guys) = partition (isEmptyVarSet . ambig_tv_fn) irreds
 220         ambig_tv_fn dict    = tyVarsOfInst dict `minusVarSet` avail_tvs
 221     in
 222     addAmbigErrs ambig_tv_fn bad_guys   `thenNF_Tc_`
 223
 224
 225         -- Finished
 226     returnTc (mkLIE frees, binds, mkLIE irreds')
 227   where
 228     wanteds = bagToList wanted_lie
 229
 230     try_me inst
 231       -- Does not constrain a local tyvar
 232       | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
 233       = -- if is_top_level then
 234         --   FreeIfTautological           -- Special case for inference on
 235         --                                -- top-level defns
 236         -- else
 237         Free
 238
 239       -- We're infering (not checking) the type, and
 240       -- the inst constrains a local type variable
 241       | isDict inst  = DontReduce               -- Dicts
 242       | otherwise    = ReduceMe AddToIrreds     -- Lits and Methods
 243 \end{code}
 244
 245 @tcSimplifyAndCheck@ is similar to the above, except that it checks
 246 that there is an empty wanted-set at the end.  It may still return
 247 some of constant insts, which have to be resolved finally at the end.
 248
 249 \begin{code}
 250 tcSimplifyAndCheck
 251          :: SDoc
 252          -> TcTyVarSet          -- ``Local''  type variables
 253                                 -- ASSERT: this tyvar set is already zonked
 254          -> LIE                 -- Given; constrain only local tyvars
 255          -> LIE                 -- Wanted
 256          -> TcM s (LIE,         -- Free
 257                    TcDictBinds) -- Bindings
 258
 259 tcSimplifyAndCheck str local_tvs given_lie wanted_lie
 260   | isEmptyVarSet local_tvs
 261         -- This can happen quite legitimately; for example in
 262         --      instance Num Int where ...
 263   = returnTc (wanted_lie, EmptyMonoBinds)
 264
 265   | otherwise
 266   = reduceContext str try_me givens wanteds     `thenTc` \ (binds, frees, irreds) ->
 267
 268         -- Complain about any irreducible ones
 269     mapNF_Tc complain irreds    `thenNF_Tc_`
 270
 271         -- Done
 272     returnTc (mkLIE frees, binds)
 273   where
 274     givens  = bagToList given_lie
 275     wanteds = bagToList wanted_lie
 276     given_dicts = filter isDict givens
 277
 278     try_me inst
 279       -- Does not constrain a local tyvar
 280       | isEmptyVarSet (tyVarsOfInst inst `intersectVarSet` local_tvs)
 281       = Free
 282
 283       -- When checking against a given signature we always reduce
 284       -- until we find a match against something given, or can't reduce
 285       | otherwise
 286       = ReduceMe AddToIrreds
 287
 288     complain dict = mapNF_Tc zonkInst givens    `thenNF_Tc` \ givens ->
 289                     addNoInstanceErr str given_dicts dict
 290 \end{code}
 291
 292 On the LHS of transformation rules we only simplify methods and constants,
 293 getting dictionaries.  We want to keep all of them unsimplified, to serve
 294 as the available stuff for the RHS of the rule.
 295
 296 The same thing is used for specialise pragmas. Consider
 297
 298         f :: Num a => a -> a
 299         {-# SPECIALISE f :: Int -> Int #-}
 300         f = ...
 301
 302 The type checker generates a binding like:
 303
 304         f_spec = (f :: Int -> Int)
 305
 306 and we want to end up with
 307
 308         f_spec = _inline_me_ (f Int dNumInt)
 309
 310 But that means that we must simplify the Method for f to (f Int dNumInt)!
 311 So tcSimplifyToDicts squeezes out all Methods.
 312
 313 \begin{code}
 314 tcSimplifyToDicts :: LIE -> TcM s (LIE, TcDictBinds)
 315 tcSimplifyToDicts wanted_lie
 316   = reduceContext (text "tcSimplifyToDicts") try_me [] wanteds  `thenTc` \ (binds, frees, irreds) ->
 317     ASSERT( null frees )
 318     returnTc (mkLIE irreds, binds)
 319   where
 320     wanteds     = bagToList wanted_lie
 321
 322         -- Reduce methods and lits only; stop as soon as we get a dictionary
 323     try_me inst | isDict inst = DontReduce
 324                 | otherwise   = ReduceMe AddToIrreds
 325 \end{code}
 326
 327
 328
 329 %************************************************************************
 330 %*                                                                      *
 331 \subsection{Data types for the reduction mechanism}
 332 %*                                                                      *
 333 %************************************************************************
 334
 335 The main control over context reduction is here
 336
 337 \begin{code}
 338 data WhatToDo
 339  = ReduceMe               -- Try to reduce this
 340         NoInstanceAction  -- What to do if there's no such instance
 341
 342  | DontReduce             -- Return as irreducible
 343
 344  | Free                   -- Return as free
 345
 346  | FreeIfTautological     -- Return as free iff it's tautological;
 347                           -- if not, return as irreducible
 348         -- The FreeIfTautological case is to allow the possibility
 349         -- of generating functions with types like
 350         --      f :: C Int => Int -> Int
 351         -- Here, the C Int isn't a tautology presumably because Int
 352         -- isn't an instance of C in this module; but perhaps it will
 353         -- be at f's call site(s).  Haskell doesn't allow this at
 354         -- present.
 355
 356 data NoInstanceAction
 357   = Stop                -- Fail; no error message
 358                         -- (Only used when tautology checking.)
 359
 360   | AddToIrreds         -- Just add the inst to the irreductible ones; don't
 361                         -- produce an error message of any kind.
 362                         -- It might be quite legitimate such as (Eq a)!
 363 \end{code}
 364
 365
 366
 367 \begin{code}
 368 type RedState s
 369   = (Avails s,          -- What's available
 370      [Inst],            -- Insts for which try_me returned Free
 371      [Inst]             -- Insts for which try_me returned DontReduce
 372     )
 373
 374 type Avails s = FiniteMap Inst Avail
 375
 376 data Avail
 377   = Avail
 378         TcId            -- The "main Id"; that is, the Id for the Inst that
 379                         -- caused this avail to be put into the finite map in the first place
 380                         -- It is this Id that is bound to the RHS.
 381
 382         RHS             -- The RHS: an expression whose value is that Inst.
 383                         -- The main Id should be bound to this RHS
 384
 385         [TcId]  -- Extra Ids that must all be bound to the main Id.
 386                         -- At the end we generate a list of bindings
 387                         --       { i1 = main_id; i2 = main_id; i3 = main_id; ... }
 388
 389 data RHS
 390   = NoRhs               -- Used for irreducible dictionaries,
 391                         -- which are going to be lambda bound, or for those that are
 392                         -- suppplied as "given" when checking againgst a signature.
 393                         --
 394                         -- NoRhs is also used for Insts like (CCallable f)
 395                         -- where no witness is required.
 396
 397   | Rhs                 -- Used when there is a RHS
 398         TcExpr
 399         Bool            -- True => the RHS simply selects a superclass dictionary
 400                         --         from a subclass dictionary.
 401                         -- False => not so.
 402                         -- This is useful info, because superclass selection
 403                         -- is cheaper than building the dictionary using its dfun,
 404                         -- and we can sometimes replace the latter with the former
 405
 406   | PassiveScSel        -- Used for as-yet-unactivated RHSs.  For example suppose we have
 407                         -- an (Ord t) dictionary; then we put an (Eq t) entry in
 408                         -- the finite map, with an PassiveScSel.  Then if the
 409                         -- the (Eq t) binding is ever *needed* we make it an Rhs
 410         TcExpr
 411         [Inst]  -- List of Insts that are free in the RHS.
 412                         -- If the main Id is subsequently needed, we toss this list into
 413                         -- the needed-inst pool so that we make sure their bindings
 414                         -- will actually be produced.
 415                         --
 416                         -- Invariant: these Insts are already in the finite mapping
 417
 418
 419 pprAvails avails = vcat (map pp (eltsFM avails))
 420   where
 421     pp (Avail main_id rhs ids)
 422       = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
 423
 424 pprRhs NoRhs = text "<no rhs>"
 425 pprRhs (Rhs rhs b) = ppr rhs
 426 pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs
 427 \end{code}
 428
 429
 430 %************************************************************************
 431 %*                                                                      *
 432 \subsection[reduce]{@reduce@}
 433 %*                                                                      *
 434 %************************************************************************
 435
 436 The main entry point for context reduction is @reduceContext@:
 437
 438 \begin{code}
 439 reduceContext :: SDoc -> (Inst -> WhatToDo)
 440               -> [Inst] -- Given
 441               -> [Inst] -- Wanted
 442               -> TcM s (TcDictBinds,
 443                         [Inst],         -- Free
 444                         [Inst])         -- Irreducible
 445
 446 reduceContext str try_me givens wanteds
 447   =     -- Zonking first
 448     mapNF_Tc zonkInst givens    `thenNF_Tc` \ givens ->
 449     mapNF_Tc zonkInst wanteds   `thenNF_Tc` \ wanteds ->
 450
 451 {-
 452     pprTrace "reduceContext" (vcat [
 453              text "----------------------",
 454              str,
 455              text "given" <+> ppr givens,
 456              text "wanted" <+> ppr wanteds,
 457              text "----------------------"
 458              ]) $
 459 -}
 460         -- Build the Avail mapping from "givens"
 461     foldlNF_Tc addGiven emptyFM givens          `thenNF_Tc` \ avails ->
 462
 463         -- Do the real work
 464     reduceList (0,[]) try_me wanteds (avails, [], [])   `thenTc` \ (avails, frees, irreds) ->
 465
 466         -- Extract the bindings from avails
 467     let
 468        binds = foldFM add_bind EmptyMonoBinds avails
 469
 470        add_bind _ (Avail main_id rhs ids) binds
 471          = foldr add_synonym (add_rhs_bind rhs binds) ids
 472          where
 473            add_rhs_bind (Rhs rhs _) binds = binds `AndMonoBinds` VarMonoBind main_id rhs
 474            add_rhs_bind other       binds = binds
 475
 476            -- Add the trivial {x = y} bindings
 477            -- The main Id can end up in the list when it's first added passively
 478            -- and then activated, so we have to filter it out.  A bit of a hack.
 479            add_synonym id binds
 480              | id /= main_id = binds `AndMonoBinds` VarMonoBind id (HsVar main_id)
 481              | otherwise     = binds
 482     in
 483 {-
 484     pprTrace ("reduceContext end") (vcat [
 485              text "----------------------",
 486              str,
 487              text "given" <+> ppr givens,
 488              text "wanted" <+> ppr wanteds,
 489              text "----",
 490              text "avails" <+> pprAvails avails,
 491              text "irreds" <+> ppr irreds,
 492              text "----------------------"
 493              ]) $
 494 -}
 495     returnTc (binds, frees, irreds)
 496 \end{code}
 497
 498 The main context-reduction function is @reduce@.  Here's its game plan.
 499
 500 \begin{code}
 501 reduceList :: (Int,[Inst])              -- Stack (for err msgs)
 502                                         -- along with its depth
 503            -> (Inst -> WhatToDo)
 504            -> [Inst]
 505            -> RedState s
 506            -> TcM s (RedState s)
 507 \end{code}
 508
 509 @reduce@ is passed
 510      try_me:    given an inst, this function returns
 511                   Reduce       reduce this
 512                   DontReduce   return this in "irreds"
 513                   Free         return this in "frees"
 514
 515      wanteds:   The list of insts to reduce
 516      state:     An accumulating parameter of type RedState
 517                 that contains the state of the algorithm
 518
 519   It returns a RedState.
 520
 521 The (n,stack) pair is just used for error reporting.
 522 n is always the depth of the stack.
 523 The stack is the stack of Insts being reduced: to produce X
 524 I had to produce Y, to produce Y I had to produce Z, and so on.
 525
 526 \begin{code}
 527 reduceList (n,stack) try_me wanteds state
 528   | n > opt_MaxContextReductionDepth
 529   = failWithTc (reduceDepthErr n stack)
 530
 531   | otherwise
 532   =
 533 #ifdef DEBUG
 534    (if n > 8 then
 535         pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
 536     else (\x->x))
 537 #endif
 538     go wanteds state
 539   where
 540     go []     state = returnTc state
 541     go (w:ws) state = reduce (n+1, w:stack) try_me w state      `thenTc` \ state' ->
 542                       go ws state'
 543
 544     -- Base case: we're done!
 545 reduce stack try_me wanted state@(avails, frees, irreds)
 546     -- It's the same as an existing inst, or a superclass thereof
 547   | wanted `elemFM` avails
 548   = returnTc (activate avails wanted, frees, irreds)
 549
 550   | otherwise
 551   = case try_me wanted of {
 552
 553     ReduceMe no_instance_action ->      -- It should be reduced
 554         lookupInst wanted             `thenNF_Tc` \ lookup_result ->
 555         case lookup_result of
 556             GenInst wanteds' rhs -> use_instance wanteds' rhs
 557             SimpleInst rhs       -> use_instance []       rhs
 558
 559             NoInstance ->    -- No such instance!
 560                     case no_instance_action of
 561                         Stop        -> failTc
 562                         AddToIrreds -> add_to_irreds
 563     ;
 564     Free ->     -- It's free and this isn't a top-level binding, so just chuck it upstairs
 565                 -- First, see if the inst can be reduced to a constant in one step
 566         lookupInst wanted         `thenNF_Tc` \ lookup_result ->
 567         case lookup_result of
 568             SimpleInst rhs -> use_instance [] rhs
 569             other          -> add_to_frees
 570
 571
 572
 573     ;
 574     FreeIfTautological -> -- It's free and this is a top level binding, so
 575                           -- check whether it's a tautology or not
 576         tryTc_
 577           add_to_irreds   -- If tautology trial fails, add to irreds
 578
 579           -- If tautology succeeds, just add to frees
 580           (reduce stack try_me_taut wanted (avails, [], [])     `thenTc_`
 581            returnTc (avails, wanted:frees, irreds))
 582
 583
 584     ;
 585     DontReduce ->    -- It's irreducible (or at least should not be reduced)
 586         -- See if the inst can be reduced to a constant in one step
 587         lookupInst wanted         `thenNF_Tc` \ lookup_result ->
 588         case lookup_result of
 589            SimpleInst rhs -> use_instance [] rhs
 590            other          -> add_to_irreds
 591     }
 592   where
 593         -- The three main actions
 594     add_to_frees  = let
 595                         avails' = addFree avails wanted
 596                         -- Add the thing to the avails set so any identical Insts
 597                         -- will be commoned up with it right here
 598                     in
 599                     returnTc (avails', wanted:frees, irreds)
 600
 601     add_to_irreds = addGiven avails wanted              `thenNF_Tc` \ avails' ->
 602                     returnTc (avails',  frees, wanted:irreds)
 603
 604     use_instance wanteds' rhs = addWanted avails wanted rhs     `thenNF_Tc` \ avails' ->
 605                                 reduceList stack try_me wanteds' (avails', frees, irreds)
 606
 607
 608     -- The try-me to use when trying to identify tautologies
 609     -- It blunders on reducing as much as possible
 610     try_me_taut inst = ReduceMe Stop    -- No error recovery
 611 \end{code}
 612
 613
 614 \begin{code}
 615 activate :: Avails s -> Inst -> Avails s
 616          -- Activate the binding for Inst, ensuring that a binding for the
 617          -- wanted Inst will be generated.
 618          -- (Activate its parent if necessary, recursively).
 619          -- Precondition: the Inst is in Avails already
 620
 621 activate avails wanted
 622   | not (instBindingRequired wanted)
 623   = avails
 624
 625   | otherwise
 626   = case lookupFM avails wanted of
 627
 628       Just (Avail main_id (PassiveScSel rhs insts) ids) ->
 629                foldl activate avails' insts      -- Activate anything it needs
 630              where
 631                avails' = addToFM avails wanted avail'
 632                avail'  = Avail main_id (Rhs rhs True) (wanted_id : ids) -- Activate it
 633
 634       Just (Avail main_id other_rhs ids) -> -- Just add to the synonyms list
 635                addToFM avails wanted (Avail main_id other_rhs (wanted_id : ids))
 636
 637       Nothing -> panic "activate"
 638   where
 639       wanted_id = instToId wanted
 640
 641 addWanted avails wanted rhs_expr
 642   = ASSERT( not (wanted `elemFM` avails) )
 643     returnNF_Tc (addToFM avails wanted avail)
 644         -- NB: we don't add the thing's superclasses too!
 645         -- Why not?  Because addWanted is used when we've successfully used an
 646         -- instance decl to reduce something; e.g.
 647         --      d:Ord [a] = dfunOrd (d1:Eq [a]) (d2:Ord a)
 648         -- Note that we pass the superclasses to the dfun, so they will be "wanted".
 649         -- If we put the superclasses of "d" in avails, then we might end up
 650         -- expressing "d1" in terms of "d", which would be a disaster.
 651   where
 652     avail = Avail (instToId wanted) rhs []
 653
 654     rhs | instBindingRequired wanted = Rhs rhs_expr False       -- Not superclass selection
 655         | otherwise                  = NoRhs
 656
 657 addFree :: Avails s -> Inst -> (Avails s)
 658         -- When an Inst is tossed upstairs as 'free' we nevertheless add it
 659         -- to avails, so that any other equal Insts will be commoned up right
 660         -- here rather than also being tossed upstairs.  This is really just
 661         -- an optimisation, and perhaps it is more trouble that it is worth,
 662         -- as the following comments show!
 663         --
 664         -- NB1: do *not* add superclasses.  If we have
 665         --      df::Floating a
 666         --      dn::Num a
 667         -- but a is not bound here, then we *don't* want to derive
 668         -- dn from df here lest we lose sharing.
 669         --
 670         -- NB2: do *not* add the Inst to avails at all if it's a method.
 671         -- The following situation shows why this is bad:
 672         --      truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
 673         -- From an application (truncate f i) we get
 674         --      t1 = truncate at f
 675         --      t2 = t1 at i
 676         -- If we have also have a secon occurrence of truncate, we get
 677         --      t3 = truncate at f
 678         --      t4 = t3 at i
 679         -- When simplifying with i,f free, we might still notice that
 680         --   t1=t3; but alas, the binding for t2 (which mentions t1)
 681         --   will continue to float out!
 682         -- Solution: never put methods in avail till they are captured
 683         -- in which case addFree isn't used
 684 addFree avails free
 685   | isDict free = addToFM avails free (Avail (instToId free) NoRhs [])
 686   | otherwise   = avails
 687
 688 addGiven :: Avails s -> Inst -> NF_TcM s (Avails s)
 689 addGiven avails given
 690   =      -- ASSERT( not (given `elemFM` avails) )
 691          -- This assertion isn't necessarily true.  It's permitted
 692          -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
 693          -- and when typechecking instance decls we generate redundant "givens" too.
 694     addAvail avails given avail
 695   where
 696     avail = Avail (instToId given) NoRhs []
 697
 698 addAvail avails wanted avail
 699   = addSuperClasses (addToFM avails wanted avail) wanted
 700
 701 addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s)
 702                 -- Add all the superclasses of the Inst to Avails
 703                 -- Invariant: the Inst is already in Avails.
 704
 705 addSuperClasses avails dict
 706   | not (isDict dict)
 707   = returnNF_Tc avails
 708
 709   | otherwise   -- It is a dictionary
 710   = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels)
 711   where
 712     (clas, tys) = getDictClassTys dict
 713
 714     (tyvars, sc_theta, sc_sels, _) = classBigSig clas
 715     sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta
 716
 717     add_sc avails ((super_clas, super_tys), sc_sel)
 718       = newDictFromOld dict super_clas super_tys        `thenNF_Tc` \ super_dict ->
 719         let
 720            sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys)
 721                                 [instToId dict]
 722         in
 723         case lookupFM avails super_dict of
 724
 725              Just (Avail main_id (Rhs rhs False {- not sc selection -}) ids) ->
 726                   -- Already there, but not as a superclass selector
 727                   -- No need to look at its superclasses; since it's there
 728                   --    already they must be already in avails
 729                   -- However, we must remember to activate the dictionary
 730                   -- from which it is (now) generated
 731                   returnNF_Tc (activate avails' dict)
 732                 where
 733                   avails' = addToFM avails super_dict avail
 734                   avail   = Avail main_id (Rhs sc_sel_rhs True) ids     -- Superclass selection
 735
 736              Just (Avail _ _ _) -> returnNF_Tc avails
 737                   -- Already there; no need to do anything
 738
 739              Nothing ->
 740                   -- Not there at all, so add it, and its superclasses
 741                   addAvail avails super_dict avail
 742                 where
 743                   avail   = Avail (instToId super_dict)
 744                                   (PassiveScSel sc_sel_rhs [dict])
 745                                   []
 746 \end{code}
 747
 748 %************************************************************************
 749 %*                                                                      *
 750 \subsection[simple]{@Simple@ versions}
 751 %*                                                                      *
 752 %************************************************************************
 753
 754 Much simpler versions when there are no bindings to make!
 755
 756 @tcSimplifyThetas@ simplifies class-type constraints formed by
 757 @deriving@ declarations and when specialising instances.  We are
 758 only interested in the simplified bunch of class/type constraints.
 759
 760 It simplifies to constraints of the form (C a b c) where
 761 a,b,c are type variables.  This is required for the context of
 762 instance declarations.
 763
 764 \begin{code}
 765 tcSimplifyThetas :: (Class -> InstEnv)          -- How to find the InstEnv
 766                  -> ThetaType                   -- Wanted
 767                  -> TcM s ThetaType             -- Needed
 768
 769 tcSimplifyThetas inst_mapper wanteds
 770   = reduceSimple inst_mapper [] wanteds         `thenNF_Tc` \ irreds ->
 771     let
 772         -- For multi-param Haskell, check that the returned dictionaries
 773         -- don't have any of the form (C Int Bool) for which
 774         -- we expect an instance here
 775         -- For Haskell 98, check that all the constraints are of the form C a,
 776         -- where a is a type variable
 777         bad_guys | opt_GlasgowExts = [ct | ct@(clas,tys) <- irreds,
 778                                            isEmptyVarSet (tyVarsOfTypes tys)]
 779                  | otherwise       = [ct | ct@(clas,tys) <- irreds,
 780                                            not (all isTyVarTy tys)]
 781     in
 782     if null bad_guys then
 783         returnTc irreds
 784     else
 785        mapNF_Tc addNoInstErr bad_guys           `thenNF_Tc_`
 786        failTc
 787 \end{code}
 788
 789 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
 790 used with \tr{default} declarations.  We are only interested in
 791 whether it worked or not.
 792
 793 \begin{code}
 794 tcSimplifyCheckThetas :: ThetaType      -- Given
 795                       -> ThetaType      -- Wanted
 796                       -> TcM s ()
 797
 798 tcSimplifyCheckThetas givens wanteds
 799   = reduceSimple classInstEnv givens wanteds    `thenNF_Tc`     \ irreds ->
 800     if null irreds then
 801        returnTc ()
 802     else
 803        mapNF_Tc addNoInstErr irreds             `thenNF_Tc_`
 804        failTc
 805 \end{code}
 806
 807
 808 \begin{code}
 809 type AvailsSimple = FiniteMap (Class, [TauType]) Bool
 810                     -- True  => irreducible
 811                     -- False => given, or can be derived from a given or from an irreducible
 812
 813 reduceSimple :: (Class -> InstEnv)
 814              -> ThetaType               -- Given
 815              -> ThetaType               -- Wanted
 816              -> NF_TcM s ThetaType      -- Irreducible
 817
 818 reduceSimple inst_mapper givens wanteds
 819   = reduce_simple (0,[]) inst_mapper givens_fm wanteds  `thenNF_Tc` \ givens_fm' ->
 820     returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
 821   where
 822     givens_fm     = foldl addNonIrred emptyFM givens
 823
 824 reduce_simple :: (Int,ThetaType)                -- Stack
 825               -> (Class -> InstEnv)
 826               -> AvailsSimple
 827               -> ThetaType
 828               -> NF_TcM s AvailsSimple
 829
 830 reduce_simple (n,stack) inst_mapper avails wanteds
 831   = go avails wanteds
 832   where
 833     go avails []     = returnNF_Tc avails
 834     go avails (w:ws) = reduce_simple_help (n+1,w:stack) inst_mapper avails w    `thenNF_Tc` \ avails' ->
 835                        go avails' ws
 836
 837 reduce_simple_help stack inst_mapper givens wanted@(clas,tys)
 838   | wanted `elemFM` givens
 839   = returnNF_Tc givens
 840
 841   | otherwise
 842   = lookupSimpleInst (inst_mapper clas) clas tys        `thenNF_Tc` \ maybe_theta ->
 843
 844     case maybe_theta of
 845       Nothing ->    returnNF_Tc (addIrred givens wanted)
 846       Just theta -> reduce_simple stack inst_mapper (addNonIrred givens wanted) theta
 847
 848 addIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
 849 addIrred givens ct
 850   = addSCs (addToFM givens ct True) ct
 851
 852 addNonIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
 853 addNonIrred givens ct
 854   = addSCs (addToFM givens ct False) ct
 855
 856 addSCs givens ct@(clas,tys)
 857  = foldl add givens sc_theta
 858  where
 859    (tyvars, sc_theta_tmpl, _, _) = classBigSig clas
 860    sc_theta = substTheta (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
 861
 862    add givens ct = case lookupFM givens ct of
 863                            Nothing    -> -- Add it and its superclasses
 864                                          addSCs (addToFM givens ct False) ct
 865
 866                            Just True  -> -- Set its flag to False; superclasses already done
 867                                          addToFM givens ct False
 868
 869                            Just False -> -- Already done
 870                                          givens
 871
 872 \end{code}
 873
 874 %************************************************************************
 875 %*                                                                      *
 876 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
 877 %*                                                                      *
 878 %************************************************************************
 879
 880 When doing a binding group, we may have @Insts@ of local functions.
 881 For example, we might have...
 882 \begin{verbatim}
 883 let f x = x + 1     -- orig local function (overloaded)
 884     f.1 = f Int     -- two instances of f
 885     f.2 = f Float
 886  in
 887     (f.1 5, f.2 6.7)
 888 \end{verbatim}
 889 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
 890 where @f@ is in scope; those @Insts@ must certainly not be passed
 891 upwards towards the top-level.  If the @Insts@ were binding-ified up
 892 there, they would have unresolvable references to @f@.
 893
 894 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
 895 For each method @Inst@ in the @init_lie@ that mentions one of the
 896 @Ids@, we create a binding.  We return the remaining @Insts@ (in an
 897 @LIE@), as well as the @HsBinds@ generated.
 898
 899 \begin{code}
 900 bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM s (LIE, TcMonoBinds)
 901
 902 bindInstsOfLocalFuns init_lie local_ids
 903   | null overloaded_ids || null lie_for_here
 904         -- Common case
 905   = returnTc (init_lie, EmptyMonoBinds)
 906
 907   | otherwise
 908   = reduceContext (text "bindInsts" <+> ppr local_ids)
 909                   try_me [] lie_for_here        `thenTc` \ (binds, frees, irreds) ->
 910     ASSERT( null irreds )
 911     returnTc (mkLIE frees `plusLIE` mkLIE lie_not_for_here, binds)
 912   where
 913     overloaded_ids = filter is_overloaded local_ids
 914     is_overloaded id = case splitSigmaTy (idType id) of
 915                           (_, theta, _) -> not (null theta)
 916
 917     overloaded_set = mkVarSet overloaded_ids    -- There can occasionally be a lot of them
 918                                                 -- so it's worth building a set, so that
 919                                                 -- lookup (in isMethodFor) is faster
 920
 921         -- No sense in repeatedly zonking lots of
 922         -- constant constraints so filter them out here
 923     (lie_for_here, lie_not_for_here) = partition (isMethodFor overloaded_set)
 924                                                  (bagToList init_lie)
 925     try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds
 926                 | otherwise                       = Free
 927 \end{code}
 928
 929
 930 %************************************************************************
 931 %*                                                                      *
 932 \section[Disambig]{Disambiguation of overloading}
 933 %*                                                                      *
 934 %************************************************************************
 935
 936
 937 If a dictionary constrains a type variable which is
 938 \begin{itemize}
 939 \item
 940 not mentioned in the environment
 941 \item
 942 and not mentioned in the type of the expression
 943 \end{itemize}
 944 then it is ambiguous. No further information will arise to instantiate
 945 the type variable; nor will it be generalised and turned into an extra
 946 parameter to a function.
 947
 948 It is an error for this to occur, except that Haskell provided for
 949 certain rules to be applied in the special case of numeric types.
 950
 951 Specifically, if
 952 \begin{itemize}
 953 \item
 954 at least one of its classes is a numeric class, and
 955 \item
 956 all of its classes are numeric or standard
 957 \end{itemize}
 958 then the type variable can be defaulted to the first type in the
 959 default-type list which is an instance of all the offending classes.
 960
 961 So here is the function which does the work.  It takes the ambiguous
 962 dictionaries and either resolves them (producing bindings) or
 963 complains.  It works by splitting the dictionary list by type
 964 variable, and using @disambigOne@ to do the real business.
 965
 966
 967 @tcSimplifyTop@ is called once per module to simplify
 968 all the constant and ambiguous Insts.
 969
 970 \begin{code}
 971 tcSimplifyTop :: LIE -> TcM s TcDictBinds
 972 tcSimplifyTop wanted_lie
 973   = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) ->
 974     ASSERT( null frees )
 975
 976     let
 977                 -- All the non-std ones are definite errors
 978         (stds, non_stds) = partition isStdClassTyVarDict irreds
 979
 980
 981                 -- Group by type variable
 982         std_groups = equivClasses cmp_by_tyvar stds
 983
 984                 -- Pick the ones which its worth trying to disambiguate
 985         (std_oks, std_bads) = partition worth_a_try std_groups
 986                 -- Have a try at disambiguation
 987                 -- if the type variable isn't bound
 988                 -- up with one of the non-standard classes
 989         worth_a_try group@(d:_) = isEmptyVarSet (tyVarsOfInst d `intersectVarSet` non_std_tyvars)
 990         non_std_tyvars          = unionVarSets (map tyVarsOfInst non_stds)
 991
 992                 -- Collect together all the bad guys
 993         bad_guys = non_stds ++ concat std_bads
 994     in
 995
 996         -- Disambiguate the ones that look feasible
 997     mapTc disambigGroup std_oks         `thenTc` \ binds_ambig ->
 998
 999         -- And complain about the ones that don't
1000     mapNF_Tc complain bad_guys          `thenNF_Tc_`
1001
1002     returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig)
1003   where
1004     wanteds     = bagToList wanted_lie
1005     try_me inst = ReduceMe AddToIrreds
1006
1007     d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
1008
1009     complain d | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d
1010                | otherwise                      = addAmbigErr tyVarsOfInst d
1011
1012 get_tv d   = case getDictClassTys d of
1013                    (clas, [ty]) -> getTyVar "tcSimplifyTop" ty
1014 get_clas d = case getDictClassTys d of
1015                    (clas, [ty]) -> clas
1016 \end{code}
1017
1018 @disambigOne@ assumes that its arguments dictionaries constrain all
1019 the same type variable.
1020
1021 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
1022 @()@ instead of @Int@.  I reckon this is the Right Thing to do since
1023 the most common use of defaulting is code like:
1024 \begin{verbatim}
1025         _ccall_ foo     `seqPrimIO` bar
1026 \end{verbatim}
1027 Since we're not using the result of @foo@, the result if (presumably)
1028 @void@.
1029
1030 \begin{code}
1031 disambigGroup :: [Inst] -- All standard classes of form (C a)
1032               -> TcM s TcDictBinds
1033
1034 disambigGroup dicts
1035   |   any isNumericClass classes        -- Guaranteed all standard classes
1036           -- see comment at the end of function for reasons as to
1037           -- why the defaulting mechanism doesn't apply to groups that
1038           -- include CCallable or CReturnable dicts.
1039    && not (any isCcallishClass classes)
1040   =     -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
1041         -- SO, TRY DEFAULT TYPES IN ORDER
1042
1043         -- Failure here is caused by there being no type in the
1044         -- default list which can satisfy all the ambiguous classes.
1045         -- For example, if Real a is reqd, but the only type in the
1046         -- default list is Int.
1047     tcGetDefaultTys                     `thenNF_Tc` \ default_tys ->
1048     let
1049       try_default []    -- No defaults work, so fail
1050         = failTc
1051
1052       try_default (default_ty : default_tys)
1053         = tryTc_ (try_default default_tys) $    -- If default_ty fails, we try
1054                                                 -- default_tys instead
1055           tcSimplifyCheckThetas [] thetas       `thenTc` \ _ ->
1056           returnTc default_ty
1057         where
1058           thetas = classes `zip` repeat [default_ty]
1059     in
1060         -- See if any default works, and if so bind the type variable to it
1061         -- If not, add an AmbigErr
1062     recoverTc (complain dicts `thenNF_Tc_` returnTc EmptyMonoBinds)     $
1063
1064     try_default default_tys                     `thenTc` \ chosen_default_ty ->
1065
1066         -- Bind the type variable and reduce the context, for real this time
1067     let
1068         chosen_default_tc_ty = typeToTcType chosen_default_ty   -- Tiresome!
1069     in
1070     unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar)   `thenTc_`
1071     reduceContext (text "disambig" <+> ppr dicts)
1072                   try_me [] dicts                       `thenTc` \ (binds, frees, ambigs) ->
1073     ASSERT( null frees && null ambigs )
1074     warnDefault dicts chosen_default_ty                 `thenTc_`
1075     returnTc binds
1076
1077   | all isCreturnableClass classes
1078   =     -- Default CCall stuff to (); we don't even both to check that () is an
1079         -- instance of CReturnable, because we know it is.
1080     unifyTauTy (mkTyVarTy tyvar) unitTy    `thenTc_`
1081     returnTc EmptyMonoBinds
1082
1083   | otherwise -- No defaults
1084   = complain dicts      `thenNF_Tc_`
1085     returnTc EmptyMonoBinds
1086
1087   where
1088     complain    = addAmbigErrs tyVarsOfInst
1089     try_me inst = ReduceMe AddToIrreds          -- This reduce should not fail
1090     tyvar       = get_tv (head dicts)           -- Should be non-empty
1091     classes     = map get_clas dicts
1092 \end{code}
1093
1094 [Aside - why the defaulting mechanism is turned off when
1095  dealing with arguments and results to ccalls.
1096
1097 When typechecking _ccall_s, TcExpr ensures that the external
1098 function is only passed arguments (and in the other direction,
1099 results) of a restricted set of 'native' types. This is
1100 implemented via the help of the pseudo-type classes,
1101 @CReturnable@ (CR) and @CCallable@ (CC.)
1102
1103 The interaction between the defaulting mechanism for numeric
1104 values and CC & CR can be a bit puzzling to the user at times.
1105 For example,
1106
1107     x <- _ccall_ f
1108     if (x /= 0) then
1109        _ccall_ g x
1110      else
1111        return ()
1112
1113 What type has 'x' got here? That depends on the default list
1114 in operation, if it is equal to Haskell 98's default-default
1115 of (Integer, Double), 'x' has type Double, since Integer
1116 is not an instance of CR. If the default list is equal to
1117 Haskell 1.4's default-default of (Int, Double), 'x' has type
1118 Int.
1119
1120 To try to minimise the potential for surprises here, the
1121 defaulting mechanism is turned off in the presence of
1122 CCallable and CReturnable.
1123
1124 ]
1125
1126 Errors and contexts
1127 ~~~~~~~~~~~~~~~~~~~
1128 ToDo: for these error messages, should we note the location as coming
1129 from the insts, or just whatever seems to be around in the monad just
1130 now?
1131
1132 \begin{code}
1133 genCantGenErr insts     -- Can't generalise these Insts
1134   = sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
1135          nest 4 (pprInstsInFull insts)
1136         ]
1137
1138 addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts
1139
1140 addAmbigErr ambig_tv_fn dict
1141   = addInstErrTcM (instLoc dict)
1142         (tidy_env,
1143          sep [text "Ambiguous type variable(s)" <+>
1144                         hsep (punctuate comma (map (quotes . ppr) ambig_tvs)),
1145               nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict))])
1146   where
1147     ambig_tvs = varSetElems (ambig_tv_fn tidy_dict)
1148     (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1149
1150 warnDefault dicts default_ty
1151   | not opt_WarnTypeDefaults
1152   = returnNF_Tc ()
1153
1154   | otherwise
1155   = warnTc True msg
1156   where
1157     msg | length dicts > 1
1158         = (ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty))
1159           $$ pprInstsInFull tidy_dicts
1160         | otherwise
1161         = ptext SLIT("Defaulting") <+> quotes (pprInst (head tidy_dicts)) <+>
1162           ptext SLIT("to type") <+> quotes (ppr default_ty)
1163
1164     (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts
1165
1166 addRuleLhsErr dict
1167   = addInstErrTcM (instLoc dict)
1168         (tidy_env,
1169          vcat [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
1170                nest 4 (ptext SLIT("LHS of a rule must have no overloading"))])
1171   where
1172     (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1173
1174 -- Used for top-level irreducibles
1175 addTopInstanceErr dict
1176   = addInstErrTcM (instLoc dict)
1177         (tidy_env,
1178          ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict))
1179   where
1180     (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1181
1182 addNoInstanceErr str givens dict
1183   = addInstErrTcM (instLoc dict)
1184         (tidy_env,
1185          sep [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
1186               nest 4 $ ptext SLIT("from the context:") <+> pprInsts tidy_givens]
1187         $$
1188          ptext SLIT("Probable cause:") <+>
1189               vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict),
1190                     ptext SLIT("in") <+> str],
1191                     if all_tyvars then empty else
1192                     ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)]
1193     )
1194   where
1195     all_tyvars = all isTyVarTy tys
1196     (_, tys)   = getDictClassTys dict
1197     (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
1198
1199 -- Used for the ...Thetas variants; all top level
1200 addNoInstErr (c,ts)
1201   = addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts))
1202
1203 reduceDepthErr n stack
1204   = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
1205           ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
1206           nest 4 (pprInstsInFull stack)]
1207
1208 reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)
1209 \end{code}