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