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, tcSimplifyRuleLhs,
 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                           instLoc, getDictClassTys,
 139                           pprInst, zonkInst, tidyInst, tidyInsts,
 140                           Inst, LIE, pprInsts, pprInstsInFull, mkLIE, emptyLIE,
 141                           plusLIE, pprOrigin
 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 \begin{code}
 297 tcSimplifyRuleLhs :: LIE -> TcM s (LIE, TcDictBinds)
 298 tcSimplifyRuleLhs wanted_lie
 299   = reduceContext (text "tcSimplRuleLhs") try_me [] wanteds     `thenTc` \ (binds, frees, irreds) ->
 300     ASSERT( null frees )
 301     returnTc (mkLIE irreds, binds)
 302   where
 303     wanteds     = bagToList wanted_lie
 304
 305         -- Reduce methods and lits only; stop as soon as we get a dictionary
 306     try_me inst | isDict inst = DontReduce
 307                 | otherwise   = ReduceMe AddToIrreds
 308 \end{code}
 309
 310
 311 %************************************************************************
 312 %*                                                                      *
 313 \subsection{Data types for the reduction mechanism}
 314 %*                                                                      *
 315 %************************************************************************
 316
 317 The main control over context reduction is here
 318
 319 \begin{code}
 320 data WhatToDo
 321  = ReduceMe               -- Try to reduce this
 322         NoInstanceAction  -- What to do if there's no such instance
 323
 324  | DontReduce             -- Return as irreducible
 325
 326  | Free                   -- Return as free
 327
 328  | FreeIfTautological     -- Return as free iff it's tautological;
 329                           -- if not, return as irreducible
 330         -- The FreeIfTautological case is to allow the possibility
 331         -- of generating functions with types like
 332         --      f :: C Int => Int -> Int
 333         -- Here, the C Int isn't a tautology presumably because Int
 334         -- isn't an instance of C in this module; but perhaps it will
 335         -- be at f's call site(s).  Haskell doesn't allow this at
 336         -- present.
 337
 338 data NoInstanceAction
 339   = Stop                -- Fail; no error message
 340                         -- (Only used when tautology checking.)
 341
 342   | AddToIrreds         -- Just add the inst to the irreductible ones; don't
 343                         -- produce an error message of any kind.
 344                         -- It might be quite legitimate such as (Eq a)!
 345 \end{code}
 346
 347
 348
 349 \begin{code}
 350 type RedState s
 351   = (Avails s,          -- What's available
 352      [Inst],            -- Insts for which try_me returned Free
 353      [Inst]             -- Insts for which try_me returned DontReduce
 354     )
 355
 356 type Avails s = FiniteMap Inst Avail
 357
 358 data Avail
 359   = Avail
 360         TcId            -- The "main Id"; that is, the Id for the Inst that
 361                         -- caused this avail to be put into the finite map in the first place
 362                         -- It is this Id that is bound to the RHS.
 363
 364         RHS             -- The RHS: an expression whose value is that Inst.
 365                         -- The main Id should be bound to this RHS
 366
 367         [TcId]  -- Extra Ids that must all be bound to the main Id.
 368                         -- At the end we generate a list of bindings
 369                         --       { i1 = main_id; i2 = main_id; i3 = main_id; ... }
 370
 371 data RHS
 372   = NoRhs               -- Used for irreducible dictionaries,
 373                         -- which are going to be lambda bound, or for those that are
 374                         -- suppplied as "given" when checking againgst a signature.
 375                         --
 376                         -- NoRhs is also used for Insts like (CCallable f)
 377                         -- where no witness is required.
 378
 379   | Rhs                 -- Used when there is a RHS
 380         TcExpr
 381         Bool            -- True => the RHS simply selects a superclass dictionary
 382                         --         from a subclass dictionary.
 383                         -- False => not so.
 384                         -- This is useful info, because superclass selection
 385                         -- is cheaper than building the dictionary using its dfun,
 386                         -- and we can sometimes replace the latter with the former
 387
 388   | PassiveScSel        -- Used for as-yet-unactivated RHSs.  For example suppose we have
 389                         -- an (Ord t) dictionary; then we put an (Eq t) entry in
 390                         -- the finite map, with an PassiveScSel.  Then if the
 391                         -- the (Eq t) binding is ever *needed* we make it an Rhs
 392         TcExpr
 393         [Inst]  -- List of Insts that are free in the RHS.
 394                         -- If the main Id is subsequently needed, we toss this list into
 395                         -- the needed-inst pool so that we make sure their bindings
 396                         -- will actually be produced.
 397                         --
 398                         -- Invariant: these Insts are already in the finite mapping
 399
 400
 401 pprAvails avails = vcat (map pp (eltsFM avails))
 402   where
 403     pp (Avail main_id rhs ids)
 404       = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
 405
 406 pprRhs NoRhs = text "<no rhs>"
 407 pprRhs (Rhs rhs b) = ppr rhs
 408 pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs
 409 \end{code}
 410
 411
 412 %************************************************************************
 413 %*                                                                      *
 414 \subsection[reduce]{@reduce@}
 415 %*                                                                      *
 416 %************************************************************************
 417
 418 The main entry point for context reduction is @reduceContext@:
 419
 420 \begin{code}
 421 reduceContext :: SDoc -> (Inst -> WhatToDo)
 422               -> [Inst] -- Given
 423               -> [Inst] -- Wanted
 424               -> TcM s (TcDictBinds,
 425                         [Inst],         -- Free
 426                         [Inst])         -- Irreducible
 427
 428 reduceContext str try_me givens wanteds
 429   =     -- Zonking first
 430     mapNF_Tc zonkInst givens    `thenNF_Tc` \ givens ->
 431     mapNF_Tc zonkInst wanteds   `thenNF_Tc` \ wanteds ->
 432
 433 {-
 434     pprTrace "reduceContext" (vcat [
 435              text "----------------------",
 436              str,
 437              text "given" <+> ppr givens,
 438              text "wanted" <+> ppr wanteds,
 439              text "----------------------"
 440              ]) $
 441 -}
 442         -- Build the Avail mapping from "givens"
 443     foldlNF_Tc addGiven emptyFM givens          `thenNF_Tc` \ avails ->
 444
 445         -- Do the real work
 446     reduceList (0,[]) try_me wanteds (avails, [], [])   `thenTc` \ (avails, frees, irreds) ->
 447
 448         -- Extract the bindings from avails
 449     let
 450        binds = foldFM add_bind EmptyMonoBinds avails
 451
 452        add_bind _ (Avail main_id rhs ids) binds
 453          = foldr add_synonym (add_rhs_bind rhs binds) ids
 454          where
 455            add_rhs_bind (Rhs rhs _) binds = binds `AndMonoBinds` VarMonoBind main_id rhs
 456            add_rhs_bind other       binds = binds
 457
 458            -- Add the trivial {x = y} bindings
 459            -- The main Id can end up in the list when it's first added passively
 460            -- and then activated, so we have to filter it out.  A bit of a hack.
 461            add_synonym id binds
 462              | id /= main_id = binds `AndMonoBinds` VarMonoBind id (HsVar main_id)
 463              | otherwise     = binds
 464     in
 465 {-
 466     pprTrace ("reduceContext end") (vcat [
 467              text "----------------------",
 468              str,
 469              text "given" <+> ppr givens,
 470              text "wanted" <+> ppr wanteds,
 471              text "----",
 472              text "avails" <+> pprAvails avails,
 473              text "irreds" <+> ppr irreds,
 474              text "----------------------"
 475              ]) $
 476 -}
 477     returnTc (binds, frees, irreds)
 478 \end{code}
 479
 480 The main context-reduction function is @reduce@.  Here's its game plan.
 481
 482 \begin{code}
 483 reduceList :: (Int,[Inst])              -- Stack (for err msgs)
 484                                         -- along with its depth
 485            -> (Inst -> WhatToDo)
 486            -> [Inst]
 487            -> RedState s
 488            -> TcM s (RedState s)
 489 \end{code}
 490
 491 @reduce@ is passed
 492      try_me:    given an inst, this function returns
 493                   Reduce       reduce this
 494                   DontReduce   return this in "irreds"
 495                   Free         return this in "frees"
 496
 497      wanteds:   The list of insts to reduce
 498      state:     An accumulating parameter of type RedState
 499                 that contains the state of the algorithm
 500
 501   It returns a RedState.
 502
 503 The (n,stack) pair is just used for error reporting.
 504 n is always the depth of the stack.
 505 The stack is the stack of Insts being reduced: to produce X
 506 I had to produce Y, to produce Y I had to produce Z, and so on.
 507
 508 \begin{code}
 509 reduceList (n,stack) try_me wanteds state
 510   | n > opt_MaxContextReductionDepth
 511   = failWithTc (reduceDepthErr n stack)
 512
 513   | otherwise
 514   =
 515 #ifdef DEBUG
 516    (if n > 8 then
 517         pprTrace "Jeepers! ReduceContext:" (reduceDepthMsg n stack)
 518     else (\x->x))
 519 #endif
 520     go wanteds state
 521   where
 522     go []     state = returnTc state
 523     go (w:ws) state = reduce (n+1, w:stack) try_me w state      `thenTc` \ state' ->
 524                       go ws state'
 525
 526     -- Base case: we're done!
 527 reduce stack try_me wanted state@(avails, frees, irreds)
 528     -- It's the same as an existing inst, or a superclass thereof
 529   | wanted `elemFM` avails
 530   = returnTc (activate avails wanted, frees, irreds)
 531
 532   | otherwise
 533   = case try_me wanted of {
 534
 535     ReduceMe no_instance_action ->      -- It should be reduced
 536         lookupInst wanted             `thenNF_Tc` \ lookup_result ->
 537         case lookup_result of
 538             GenInst wanteds' rhs -> use_instance wanteds' rhs
 539             SimpleInst rhs       -> use_instance []       rhs
 540
 541             NoInstance ->    -- No such instance!
 542                     case no_instance_action of
 543                         Stop        -> failTc
 544                         AddToIrreds -> add_to_irreds
 545     ;
 546     Free ->     -- It's free and this isn't a top-level binding, so just chuck it upstairs
 547                 -- First, see if the inst can be reduced to a constant in one step
 548         lookupInst wanted         `thenNF_Tc` \ lookup_result ->
 549         case lookup_result of
 550             SimpleInst rhs -> use_instance [] rhs
 551             other          -> add_to_frees
 552
 553
 554
 555     ;
 556     FreeIfTautological -> -- It's free and this is a top level binding, so
 557                           -- check whether it's a tautology or not
 558         tryTc_
 559           add_to_irreds   -- If tautology trial fails, add to irreds
 560
 561           -- If tautology succeeds, just add to frees
 562           (reduce stack try_me_taut wanted (avails, [], [])     `thenTc_`
 563            returnTc (avails, wanted:frees, irreds))
 564
 565
 566     ;
 567     DontReduce ->    -- It's irreducible (or at least should not be reduced)
 568         -- See if the inst can be reduced to a constant in one step
 569         lookupInst wanted         `thenNF_Tc` \ lookup_result ->
 570         case lookup_result of
 571            SimpleInst rhs -> use_instance [] rhs
 572            other          -> add_to_irreds
 573     }
 574   where
 575         -- The three main actions
 576     add_to_frees  = let
 577                         avails' = addFree avails wanted
 578                         -- Add the thing to the avails set so any identical Insts
 579                         -- will be commoned up with it right here
 580                     in
 581                     returnTc (avails', wanted:frees, irreds)
 582
 583     add_to_irreds = addGiven avails wanted              `thenNF_Tc` \ avails' ->
 584                     returnTc (avails',  frees, wanted:irreds)
 585
 586     use_instance wanteds' rhs = addWanted avails wanted rhs     `thenNF_Tc` \ avails' ->
 587                                 reduceList stack try_me wanteds' (avails', frees, irreds)
 588
 589
 590     -- The try-me to use when trying to identify tautologies
 591     -- It blunders on reducing as much as possible
 592     try_me_taut inst = ReduceMe Stop    -- No error recovery
 593 \end{code}
 594
 595
 596 \begin{code}
 597 activate :: Avails s -> Inst -> Avails s
 598          -- Activate the binding for Inst, ensuring that a binding for the
 599          -- wanted Inst will be generated.
 600          -- (Activate its parent if necessary, recursively).
 601          -- Precondition: the Inst is in Avails already
 602
 603 activate avails wanted
 604   | not (instBindingRequired wanted)
 605   = avails
 606
 607   | otherwise
 608   = case lookupFM avails wanted of
 609
 610       Just (Avail main_id (PassiveScSel rhs insts) ids) ->
 611                foldl activate avails' insts      -- Activate anything it needs
 612              where
 613                avails' = addToFM avails wanted avail'
 614                avail'  = Avail main_id (Rhs rhs True) (wanted_id : ids) -- Activate it
 615
 616       Just (Avail main_id other_rhs ids) -> -- Just add to the synonyms list
 617                addToFM avails wanted (Avail main_id other_rhs (wanted_id : ids))
 618
 619       Nothing -> panic "activate"
 620   where
 621       wanted_id = instToId wanted
 622
 623 addWanted avails wanted rhs_expr
 624   = ASSERT( not (wanted `elemFM` avails) )
 625     returnNF_Tc (addToFM avails wanted avail)
 626         -- NB: we don't add the thing's superclasses too!
 627         -- Why not?  Because addWanted is used when we've successfully used an
 628         -- instance decl to reduce something; e.g.
 629         --      d:Ord [a] = dfunOrd (d1:Eq [a]) (d2:Ord a)
 630         -- Note that we pass the superclasses to the dfun, so they will be "wanted".
 631         -- If we put the superclasses of "d" in avails, then we might end up
 632         -- expressing "d1" in terms of "d", which would be a disaster.
 633   where
 634     avail = Avail (instToId wanted) rhs []
 635
 636     rhs | instBindingRequired wanted = Rhs rhs_expr False       -- Not superclass selection
 637         | otherwise                  = NoRhs
 638
 639 addFree :: Avails s -> Inst -> (Avails s)
 640         -- When an Inst is tossed upstairs as 'free' we nevertheless add it
 641         -- to avails, so that any other equal Insts will be commoned up right
 642         -- here rather than also being tossed upstairs.  This is really just
 643         -- an optimisation, and perhaps it is more trouble that it is worth,
 644         -- as the following comments show!
 645         --
 646         -- NB1: do *not* add superclasses.  If we have
 647         --      df::Floating a
 648         --      dn::Num a
 649         -- but a is not bound here, then we *don't* want to derive
 650         -- dn from df here lest we lose sharing.
 651         --
 652         -- NB2: do *not* add the Inst to avails at all if it's a method.
 653         -- The following situation shows why this is bad:
 654         --      truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
 655         -- From an application (truncate f i) we get
 656         --      t1 = truncate at f
 657         --      t2 = t1 at i
 658         -- If we have also have a secon occurrence of truncate, we get
 659         --      t3 = truncate at f
 660         --      t4 = t3 at i
 661         -- When simplifying with i,f free, we might still notice that
 662         --   t1=t3; but alas, the binding for t2 (which mentions t1)
 663         --   will continue to float out!
 664         -- Solution: never put methods in avail till they are captured
 665         -- in which case addFree isn't used
 666 addFree avails free
 667   | isDict free = addToFM avails free (Avail (instToId free) NoRhs [])
 668   | otherwise   = avails
 669
 670 addGiven :: Avails s -> Inst -> NF_TcM s (Avails s)
 671 addGiven avails given
 672   =      -- ASSERT( not (given `elemFM` avails) )
 673          -- This assertion isn't necessarily true.  It's permitted
 674          -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
 675          -- and when typechecking instance decls we generate redundant "givens" too.
 676     addAvail avails given avail
 677   where
 678     avail = Avail (instToId given) NoRhs []
 679
 680 addAvail avails wanted avail
 681   = addSuperClasses (addToFM avails wanted avail) wanted
 682
 683 addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s)
 684                 -- Add all the superclasses of the Inst to Avails
 685                 -- Invariant: the Inst is already in Avails.
 686
 687 addSuperClasses avails dict
 688   | not (isDict dict)
 689   = returnNF_Tc avails
 690
 691   | otherwise   -- It is a dictionary
 692   = foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels)
 693   where
 694     (clas, tys) = getDictClassTys dict
 695
 696     (tyvars, sc_theta, sc_sels, _, _) = classBigSig clas
 697     sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta
 698
 699     add_sc avails ((super_clas, super_tys), sc_sel)
 700       = newDictFromOld dict super_clas super_tys        `thenNF_Tc` \ super_dict ->
 701         let
 702            sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys)
 703                                 [instToId dict]
 704         in
 705         case lookupFM avails super_dict of
 706
 707              Just (Avail main_id (Rhs rhs False {- not sc selection -}) ids) ->
 708                   -- Already there, but not as a superclass selector
 709                   -- No need to look at its superclasses; since it's there
 710                   --    already they must be already in avails
 711                   -- However, we must remember to activate the dictionary
 712                   -- from which it is (now) generated
 713                   returnNF_Tc (activate avails' dict)
 714                 where
 715                   avails' = addToFM avails super_dict avail
 716                   avail   = Avail main_id (Rhs sc_sel_rhs True) ids     -- Superclass selection
 717
 718              Just (Avail _ _ _) -> returnNF_Tc avails
 719                   -- Already there; no need to do anything
 720
 721              Nothing ->
 722                   -- Not there at all, so add it, and its superclasses
 723                   addAvail avails super_dict avail
 724                 where
 725                   avail   = Avail (instToId super_dict)
 726                                   (PassiveScSel sc_sel_rhs [dict])
 727                                   []
 728 \end{code}
 729
 730 %************************************************************************
 731 %*                                                                      *
 732 \subsection[simple]{@Simple@ versions}
 733 %*                                                                      *
 734 %************************************************************************
 735
 736 Much simpler versions when there are no bindings to make!
 737
 738 @tcSimplifyThetas@ simplifies class-type constraints formed by
 739 @deriving@ declarations and when specialising instances.  We are
 740 only interested in the simplified bunch of class/type constraints.
 741
 742 It simplifies to constraints of the form (C a b c) where
 743 a,b,c are type variables.  This is required for the context of
 744 instance declarations.
 745
 746 \begin{code}
 747 tcSimplifyThetas :: (Class -> InstEnv)          -- How to find the InstEnv
 748                  -> ThetaType                   -- Wanted
 749                  -> TcM s ThetaType             -- Needed
 750
 751 tcSimplifyThetas inst_mapper wanteds
 752   = reduceSimple inst_mapper [] wanteds         `thenNF_Tc` \ irreds ->
 753     let
 754         -- For multi-param Haskell, check that the returned dictionaries
 755         -- don't have any of the form (C Int Bool) for which
 756         -- we expect an instance here
 757         -- For Haskell 98, check that all the constraints are of the form C a,
 758         -- where a is a type variable
 759         bad_guys | opt_GlasgowExts = [ct | ct@(clas,tys) <- irreds,
 760                                            isEmptyVarSet (tyVarsOfTypes tys)]
 761                  | otherwise       = [ct | ct@(clas,tys) <- irreds,
 762                                            not (all isTyVarTy tys)]
 763     in
 764     if null bad_guys then
 765         returnTc irreds
 766     else
 767        mapNF_Tc addNoInstErr bad_guys           `thenNF_Tc_`
 768        failTc
 769 \end{code}
 770
 771 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
 772 used with \tr{default} declarations.  We are only interested in
 773 whether it worked or not.
 774
 775 \begin{code}
 776 tcSimplifyCheckThetas :: ThetaType      -- Given
 777                       -> ThetaType      -- Wanted
 778                       -> TcM s ()
 779
 780 tcSimplifyCheckThetas givens wanteds
 781   = reduceSimple classInstEnv givens wanteds    `thenNF_Tc`     \ irreds ->
 782     if null irreds then
 783        returnTc ()
 784     else
 785        mapNF_Tc addNoInstErr irreds             `thenNF_Tc_`
 786        failTc
 787 \end{code}
 788
 789
 790 \begin{code}
 791 type AvailsSimple = FiniteMap (Class, [TauType]) Bool
 792                     -- True  => irreducible
 793                     -- False => given, or can be derived from a given or from an irreducible
 794
 795 reduceSimple :: (Class -> InstEnv)
 796              -> ThetaType               -- Given
 797              -> ThetaType               -- Wanted
 798              -> NF_TcM s ThetaType      -- Irreducible
 799
 800 reduceSimple inst_mapper givens wanteds
 801   = reduce_simple (0,[]) inst_mapper givens_fm wanteds  `thenNF_Tc` \ givens_fm' ->
 802     returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
 803   where
 804     givens_fm     = foldl addNonIrred emptyFM givens
 805
 806 reduce_simple :: (Int,ThetaType)                -- Stack
 807               -> (Class -> InstEnv)
 808               -> AvailsSimple
 809               -> ThetaType
 810               -> NF_TcM s AvailsSimple
 811
 812 reduce_simple (n,stack) inst_mapper avails wanteds
 813   = go avails wanteds
 814   where
 815     go avails []     = returnNF_Tc avails
 816     go avails (w:ws) = reduce_simple_help (n+1,w:stack) inst_mapper avails w    `thenNF_Tc` \ avails' ->
 817                        go avails' ws
 818
 819 reduce_simple_help stack inst_mapper givens wanted@(clas,tys)
 820   | wanted `elemFM` givens
 821   = returnNF_Tc givens
 822
 823   | otherwise
 824   = lookupSimpleInst (inst_mapper clas) clas tys        `thenNF_Tc` \ maybe_theta ->
 825
 826     case maybe_theta of
 827       Nothing ->    returnNF_Tc (addIrred givens wanted)
 828       Just theta -> reduce_simple stack inst_mapper (addNonIrred givens wanted) theta
 829
 830 addIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
 831 addIrred givens ct
 832   = addSCs (addToFM givens ct True) ct
 833
 834 addNonIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
 835 addNonIrred givens ct
 836   = addSCs (addToFM givens ct False) ct
 837
 838 addSCs givens ct@(clas,tys)
 839  = foldl add givens sc_theta
 840  where
 841    (tyvars, sc_theta_tmpl, _, _, _) = classBigSig clas
 842    sc_theta = substTheta (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
 843
 844    add givens ct = case lookupFM givens ct of
 845                            Nothing    -> -- Add it and its superclasses
 846                                          addSCs (addToFM givens ct False) ct
 847
 848                            Just True  -> -- Set its flag to False; superclasses already done
 849                                          addToFM givens ct False
 850
 851                            Just False -> -- Already done
 852                                          givens
 853
 854 \end{code}
 855
 856 %************************************************************************
 857 %*                                                                      *
 858 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
 859 %*                                                                      *
 860 %************************************************************************
 861
 862 When doing a binding group, we may have @Insts@ of local functions.
 863 For example, we might have...
 864 \begin{verbatim}
 865 let f x = x + 1     -- orig local function (overloaded)
 866     f.1 = f Int     -- two instances of f
 867     f.2 = f Float
 868  in
 869     (f.1 5, f.2 6.7)
 870 \end{verbatim}
 871 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
 872 where @f@ is in scope; those @Insts@ must certainly not be passed
 873 upwards towards the top-level.  If the @Insts@ were binding-ified up
 874 there, they would have unresolvable references to @f@.
 875
 876 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
 877 For each method @Inst@ in the @init_lie@ that mentions one of the
 878 @Ids@, we create a binding.  We return the remaining @Insts@ (in an
 879 @LIE@), as well as the @HsBinds@ generated.
 880
 881 \begin{code}
 882 bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM s (LIE, TcMonoBinds)
 883
 884 bindInstsOfLocalFuns init_lie local_ids
 885   | null overloaded_ids || null lie_for_here
 886         -- Common case
 887   = returnTc (init_lie, EmptyMonoBinds)
 888
 889   | otherwise
 890   = reduceContext (text "bindInsts" <+> ppr local_ids)
 891                   try_me [] lie_for_here        `thenTc` \ (binds, frees, irreds) ->
 892     ASSERT( null irreds )
 893     returnTc (mkLIE frees `plusLIE` mkLIE lie_not_for_here, binds)
 894   where
 895     overloaded_ids = filter is_overloaded local_ids
 896     is_overloaded id = case splitSigmaTy (idType id) of
 897                           (_, theta, _) -> not (null theta)
 898
 899     overloaded_set = mkVarSet overloaded_ids    -- There can occasionally be a lot of them
 900                                                 -- so it's worth building a set, so that
 901                                                 -- lookup (in isMethodFor) is faster
 902
 903         -- No sense in repeatedly zonking lots of
 904         -- constant constraints so filter them out here
 905     (lie_for_here, lie_not_for_here) = partition (isMethodFor overloaded_set)
 906                                                  (bagToList init_lie)
 907     try_me inst | isMethodFor overloaded_set inst = ReduceMe AddToIrreds
 908                 | otherwise                       = Free
 909 \end{code}
 910
 911
 912 %************************************************************************
 913 %*                                                                      *
 914 \section[Disambig]{Disambiguation of overloading}
 915 %*                                                                      *
 916 %************************************************************************
 917
 918
 919 If a dictionary constrains a type variable which is
 920 \begin{itemize}
 921 \item
 922 not mentioned in the environment
 923 \item
 924 and not mentioned in the type of the expression
 925 \end{itemize}
 926 then it is ambiguous. No further information will arise to instantiate
 927 the type variable; nor will it be generalised and turned into an extra
 928 parameter to a function.
 929
 930 It is an error for this to occur, except that Haskell provided for
 931 certain rules to be applied in the special case of numeric types.
 932
 933 Specifically, if
 934 \begin{itemize}
 935 \item
 936 at least one of its classes is a numeric class, and
 937 \item
 938 all of its classes are numeric or standard
 939 \end{itemize}
 940 then the type variable can be defaulted to the first type in the
 941 default-type list which is an instance of all the offending classes.
 942
 943 So here is the function which does the work.  It takes the ambiguous
 944 dictionaries and either resolves them (producing bindings) or
 945 complains.  It works by splitting the dictionary list by type
 946 variable, and using @disambigOne@ to do the real business.
 947
 948
 949 @tcSimplifyTop@ is called once per module to simplify
 950 all the constant and ambiguous Insts.
 951
 952 \begin{code}
 953 tcSimplifyTop :: LIE -> TcM s TcDictBinds
 954 tcSimplifyTop wanted_lie
 955   = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) ->
 956     ASSERT( null frees )
 957
 958     let
 959                 -- All the non-std ones are definite errors
 960         (stds, non_stds) = partition isStdClassTyVarDict irreds
 961
 962
 963                 -- Group by type variable
 964         std_groups = equivClasses cmp_by_tyvar stds
 965
 966                 -- Pick the ones which its worth trying to disambiguate
 967         (std_oks, std_bads) = partition worth_a_try std_groups
 968                 -- Have a try at disambiguation
 969                 -- if the type variable isn't bound
 970                 -- up with one of the non-standard classes
 971         worth_a_try group@(d:_) = isEmptyVarSet (tyVarsOfInst d `intersectVarSet` non_std_tyvars)
 972         non_std_tyvars          = unionVarSets (map tyVarsOfInst non_stds)
 973
 974                 -- Collect together all the bad guys
 975         bad_guys = non_stds ++ concat std_bads
 976     in
 977
 978         -- Disambiguate the ones that look feasible
 979     mapTc disambigGroup std_oks         `thenTc` \ binds_ambig ->
 980
 981         -- And complain about the ones that don't
 982     mapNF_Tc complain bad_guys          `thenNF_Tc_`
 983
 984     returnTc (binds1 `andMonoBinds` andMonoBindList binds_ambig)
 985   where
 986     wanteds     = bagToList wanted_lie
 987     try_me inst = ReduceMe AddToIrreds
 988
 989     d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
 990
 991     complain d | isEmptyVarSet (tyVarsOfInst d) = addTopInstanceErr d
 992                | otherwise                      = addAmbigErr tyVarsOfInst d
 993
 994 get_tv d   = case getDictClassTys d of
 995                    (clas, [ty]) -> getTyVar "tcSimplifyTop" ty
 996 get_clas d = case getDictClassTys d of
 997                    (clas, [ty]) -> clas
 998 \end{code}
 999
1000 @disambigOne@ assumes that its arguments dictionaries constrain all
1001 the same type variable.
1002
1003 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
1004 @()@ instead of @Int@.  I reckon this is the Right Thing to do since
1005 the most common use of defaulting is code like:
1006 \begin{verbatim}
1007         _ccall_ foo     `seqPrimIO` bar
1008 \end{verbatim}
1009 Since we're not using the result of @foo@, the result if (presumably)
1010 @void@.
1011
1012 \begin{code}
1013 disambigGroup :: [Inst] -- All standard classes of form (C a)
1014               -> TcM s TcDictBinds
1015
1016 disambigGroup dicts
1017   |   any isNumericClass classes        -- Guaranteed all standard classes
1018           -- see comment at the end of function for reasons as to
1019           -- why the defaulting mechanism doesn't apply to groups that
1020           -- include CCallable or CReturnable dicts.
1021    && not (any isCcallishClass classes)
1022   =     -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
1023         -- SO, TRY DEFAULT TYPES IN ORDER
1024
1025         -- Failure here is caused by there being no type in the
1026         -- default list which can satisfy all the ambiguous classes.
1027         -- For example, if Real a is reqd, but the only type in the
1028         -- default list is Int.
1029     tcGetDefaultTys                     `thenNF_Tc` \ default_tys ->
1030     let
1031       try_default []    -- No defaults work, so fail
1032         = failTc
1033
1034       try_default (default_ty : default_tys)
1035         = tryTc_ (try_default default_tys) $    -- If default_ty fails, we try
1036                                                 -- default_tys instead
1037           tcSimplifyCheckThetas [] thetas       `thenTc` \ _ ->
1038           returnTc default_ty
1039         where
1040           thetas = classes `zip` repeat [default_ty]
1041     in
1042         -- See if any default works, and if so bind the type variable to it
1043         -- If not, add an AmbigErr
1044     recoverTc (complain dicts `thenNF_Tc_` returnTc EmptyMonoBinds)     $
1045
1046     try_default default_tys                     `thenTc` \ chosen_default_ty ->
1047
1048         -- Bind the type variable and reduce the context, for real this time
1049     let
1050         chosen_default_tc_ty = typeToTcType chosen_default_ty   -- Tiresome!
1051     in
1052     unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar)   `thenTc_`
1053     reduceContext (text "disambig" <+> ppr dicts)
1054                   try_me [] dicts                       `thenTc` \ (binds, frees, ambigs) ->
1055     ASSERT( null frees && null ambigs )
1056     warnDefault dicts chosen_default_ty                 `thenTc_`
1057     returnTc binds
1058
1059   | all isCreturnableClass classes
1060   =     -- Default CCall stuff to (); we don't even both to check that () is an
1061         -- instance of CReturnable, because we know it is.
1062     unifyTauTy (mkTyVarTy tyvar) unitTy    `thenTc_`
1063     returnTc EmptyMonoBinds
1064
1065   | otherwise -- No defaults
1066   = complain dicts      `thenNF_Tc_`
1067     returnTc EmptyMonoBinds
1068
1069   where
1070     complain    = addAmbigErrs tyVarsOfInst
1071     try_me inst = ReduceMe AddToIrreds          -- This reduce should not fail
1072     tyvar       = get_tv (head dicts)           -- Should be non-empty
1073     classes     = map get_clas dicts
1074 \end{code}
1075
1076 [Aside - why the defaulting mechanism is turned off when
1077  dealing with arguments and results to ccalls.
1078
1079 When typechecking _ccall_s, TcExpr ensures that the external
1080 function is only passed arguments (and in the other direction,
1081 results) of a restricted set of 'native' types. This is
1082 implemented via the help of the pseudo-type classes,
1083 @CReturnable@ (CR) and @CCallable@ (CC.)
1084
1085 The interaction between the defaulting mechanism for numeric
1086 values and CC & CR can be a bit puzzling to the user at times.
1087 For example,
1088
1089     x <- _ccall_ f
1090     if (x /= 0) then
1091        _ccall_ g x
1092      else
1093        return ()
1094
1095 What type has 'x' got here? That depends on the default list
1096 in operation, if it is equal to Haskell 98's default-default
1097 of (Integer, Double), 'x' has type Double, since Integer
1098 is not an instance of CR. If the default list is equal to
1099 Haskell 1.4's default-default of (Int, Double), 'x' has type
1100 Int.
1101
1102 To try to minimise the potential for surprises here, the
1103 defaulting mechanism is turned off in the presence of
1104 CCallable and CReturnable.
1105
1106 ]
1107
1108 Errors and contexts
1109 ~~~~~~~~~~~~~~~~~~~
1110 ToDo: for these error messages, should we note the location as coming
1111 from the insts, or just whatever seems to be around in the monad just
1112 now?
1113
1114 \begin{code}
1115 genCantGenErr insts     -- Can't generalise these Insts
1116   = sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
1117          nest 4 (pprInstsInFull insts)
1118         ]
1119
1120 addAmbigErrs ambig_tv_fn dicts = mapNF_Tc (addAmbigErr ambig_tv_fn) dicts
1121
1122 addAmbigErr ambig_tv_fn dict
1123   = tcAddSrcLoc (instLoc dict) $
1124     addErrTcM (tidy_env,
1125                sep [text "Ambiguous type variable(s)" <+>
1126                         hsep (punctuate comma (map (quotes . ppr) ambig_tvs)),
1127                    nest 4 (text "in the constraint" <+> quotes (pprInst tidy_dict)),
1128                    nest 4 (pprOrigin dict)])
1129   where
1130     ambig_tvs = varSetElems (ambig_tv_fn tidy_dict)
1131     (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1132
1133 warnDefault dicts default_ty
1134   | not opt_WarnTypeDefaults
1135   = returnNF_Tc ()
1136
1137   | otherwise
1138   = tcAddSrcLoc (instLoc (head dicts))          $
1139     warnTc True msg
1140   where
1141     msg | length dicts > 1
1142         = (ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty))
1143           $$ pprInstsInFull tidy_dicts
1144         | otherwise
1145         = ptext SLIT("Defaulting") <+> quotes (pprInst (head tidy_dicts)) <+>
1146           ptext SLIT("to type") <+> quotes (ppr default_ty)
1147
1148     (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts
1149
1150 addRuleLhsErr dict
1151   = tcAddSrcLoc (instLoc dict)                  $
1152     addErrTcM (tidy_env,
1153                vcat [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
1154                      nest 4 (pprOrigin dict),
1155                      ptext SLIT("LHS of a rule must have no overloading")])
1156   where
1157     (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1158
1159 -- Used for top-level irreducibles
1160 addTopInstanceErr dict
1161   = tcAddSrcLoc (instLoc dict)                 $
1162     addErrTcM (tidy_env,
1163                sep [ptext SLIT("No instance for") <+> quotes (pprInst tidy_dict),
1164                    nest 4 $ pprOrigin dict])
1165   where
1166     (tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
1167
1168 addNoInstanceErr str givens dict
1169   = tcAddSrcLoc (instLoc dict) $
1170     addErrTcM (tidy_env,
1171                sep [sep [ptext SLIT("Could not deduce") <+> quotes (pprInst tidy_dict),
1172                         nest 4 $ parens $ pprOrigin dict],
1173                    nest 4 $ ptext SLIT("from the context:") <+> pprInsts tidy_givens]
1174               $$
1175               ptext SLIT("Probable cause:") <+>
1176               vcat [sep [ptext SLIT("missing") <+> quotes (pprInst tidy_dict),
1177                          ptext SLIT("in") <+> str],
1178                     if all_tyvars then empty else
1179                     ptext SLIT("or missing instance declaration for") <+> quotes (pprInst tidy_dict)]
1180     )
1181   where
1182     all_tyvars = all isTyVarTy tys
1183     (_, tys)   = getDictClassTys dict
1184     (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
1185
1186 -- Used for the ...Thetas variants; all top level
1187 addNoInstErr (c,ts)
1188   = addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts))
1189
1190 reduceDepthErr n stack
1191   = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
1192           ptext SLIT("Use -fcontext-stack20 to increase stack size to (e.g.) 20"),
1193           nest 4 (pprInstsInFull stack)]
1194
1195 reduceDepthMsg n stack = nest 4 (pprInstsInFull stack)
1196 \end{code}