ghc/compiler/typecheck/TcSimplify.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   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 HsSyn            ( MonoBinds(..), HsExpr(..), andMonoBinds )
 127 import TcHsSyn          ( TcExpr, TcIdOcc(..), TcIdBndr,
 128                           TcMonoBinds, TcDictBinds
 129                         )
 130
 131 import TcMonad
 132 import Inst             ( lookupInst, lookupSimpleInst, LookupInstResult(..),
 133                           tyVarsOfInst,
 134                           isDict, isStdClassTyVarDict, isMethodFor,
 135                           instToId, instBindingRequired, instCanBeGeneralised,
 136                           newDictFromOld,
 137                           instLoc, getDictClassTys,
 138                           pprInst, zonkInst,
 139                           Inst(..), LIE, pprInsts, pprInstsInFull, mkLIE,
 140                           InstOrigin, pprOrigin
 141                         )
 142 import TcEnv            ( TcIdOcc(..) )
 143 import TcType           ( TcType, TcTyVarSet, TcMaybe, tcInstType, tcInstTheta )
 144 import Unify            ( unifyTauTy )
 145 import Id               ( mkIdSet )
 146
 147 import Bag              ( Bag, bagToList, snocBag )
 148 import Class            ( Class, ClassInstEnv, classBigSig, classInstEnv )
 149 import PrelInfo         ( isNumericClass, isCcallishClass )
 150
 151 import Maybes           ( maybeToBool )
 152 import Type             ( Type, ThetaType, TauType, mkTyVarTy, getTyVar,
 153                           isTyVarTy, instantiateThetaTy
 154                         )
 155 import PprType          ( pprConstraint )
 156 import TysWiredIn       ( unitTy )
 157 import TyVar            ( intersectTyVarSets, unionManyTyVarSets,
 158                           isEmptyTyVarSet, zipTyVarEnv, emptyTyVarEnv
 159                         )
 160 import FiniteMap
 161 import BasicTypes       ( TopLevelFlag(..) )
 162 import Unique           ( Unique )
 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 s                 -- ``Local''  type variables
 187                                         -- ASSERT: this tyvar set is already zonked
 188         -> LIE s                        -- Wanted
 189         -> TcM s (LIE s,                        -- Free
 190                   TcDictBinds s,                -- Bindings
 191                   LIE s)                        -- Remaining wanteds; no dups
 192
 193 tcSimplify str top_lvl local_tvs wanted_lie
 194   = reduceContext str try_me [] wanteds         `thenTc` \ (binds, frees, irreds) ->
 195
 196         -- Check for non-generalisable insts
 197     let
 198         cant_generalise = filter (not . instCanBeGeneralised) irreds
 199     in
 200     checkTc (null cant_generalise)
 201             (genCantGenErr cant_generalise)     `thenTc_`
 202
 203          -- Finished
 204     returnTc (mkLIE frees, binds, mkLIE irreds)
 205   where
 206     wanteds = bagToList wanted_lie
 207
 208     try_me inst
 209       -- Does not constrain a local tyvar
 210       | isEmptyTyVarSet (tyVarsOfInst inst `intersectTyVarSets` local_tvs)
 211       = -- if is_top_level then
 212         --   FreeIfTautological           -- Special case for inference on
 213         --                                -- top-level defns
 214         -- else
 215         Free
 216
 217       -- We're infering (not checking) the type, and
 218       -- the inst constrains a local type variable
 219       | isDict inst  = DontReduce               -- Dicts
 220       | otherwise    = ReduceMe AddToIrreds     -- Lits and Methods
 221 \end{code}
 222
 223 @tcSimplifyAndCheck@ is similar to the above, except that it checks
 224 that there is an empty wanted-set at the end.  It may still return
 225 some of constant insts, which have to be resolved finally at the end.
 226
 227 \begin{code}
 228 tcSimplifyAndCheck
 229          :: SDoc
 230          -> TcTyVarSet s                -- ``Local''  type variables
 231                                         -- ASSERT: this tyvar set is already zonked
 232          -> LIE s                       -- Given; constrain only local tyvars
 233          -> LIE s                       -- Wanted
 234          -> TcM s (LIE s,               -- Free
 235                    TcDictBinds s)       -- Bindings
 236
 237 tcSimplifyAndCheck str local_tvs given_lie wanted_lie
 238   = reduceContext str try_me givens wanteds     `thenTc` \ (binds, frees, irreds) ->
 239
 240         -- Complain about any irreducible ones
 241     mapNF_Tc complain irreds    `thenNF_Tc_`
 242
 243         -- Done
 244     returnTc (mkLIE frees, binds)
 245   where
 246     givens  = bagToList given_lie
 247     wanteds = bagToList wanted_lie
 248
 249     try_me inst
 250       -- Does not constrain a local tyvar
 251       | isEmptyTyVarSet (tyVarsOfInst inst `intersectTyVarSets` local_tvs)
 252       = Free
 253
 254       -- When checking against a given signature we always reduce
 255       -- until we find a match against something given, or can't reduce
 256       | otherwise
 257       = ReduceMe AddToIrreds
 258
 259     complain dict = mapNF_Tc zonkInst givens    `thenNF_Tc` \ givens ->
 260                     addNoInstanceErr str givens dict
 261 \end{code}
 262
 263
 264 %************************************************************************
 265 %*                                                                      *
 266 \subsection{Data types for the reduction mechanism}
 267 %*                                                                      *
 268 %************************************************************************
 269
 270 The main control over context reduction is here
 271
 272 \begin{code}
 273 data WhatToDo
 274  = ReduceMe               -- Try to reduce this
 275         NoInstanceAction  -- What to do if there's no such instance
 276
 277  | DontReduce             -- Return as irreducible
 278
 279  | Free                   -- Return as free
 280
 281  | FreeIfTautological     -- Return as free iff it's tautological;
 282                           -- if not, return as irreducible
 283
 284 data NoInstanceAction
 285   = Stop                -- Fail; no error message
 286                         -- (Only used when tautology checking.)
 287
 288   | AddToIrreds         -- Just add the inst to the irreductible ones; don't
 289                         -- produce an error message of any kind.
 290                         -- It might be quite legitimate such as (Eq a)!
 291 \end{code}
 292
 293
 294
 295 \begin{code}
 296 type RedState s
 297   = (Avails s,          -- What's available
 298      [Inst s],          -- Insts for which try_me returned Free
 299      [Inst s]           -- Insts for which try_me returned DontReduce
 300     )
 301
 302 type Avails s = FiniteMap (Inst s) (Avail s)
 303
 304 data Avail s
 305   = Avail
 306         (TcIdOcc s)     -- The "main Id"; that is, the Id for the Inst that
 307                         -- caused this avail to be put into the finite map in the first place
 308                         -- It is this Id that is bound to the RHS.
 309
 310         (RHS s)         -- The RHS: an expression whose value is that Inst.
 311                         -- The main Id should be bound to this RHS
 312
 313         [TcIdOcc s]     -- Extra Ids that must all be bound to the main Id.
 314                         -- At the end we generate a list of bindings
 315                         --       { i1 = main_id; i2 = main_id; i3 = main_id; ... }
 316
 317 data RHS s
 318   = NoRhs               -- Used for irreducible dictionaries,
 319                         -- which are going to be lambda bound, or for those that are
 320                         -- suppplied as "given" when checking againgst a signature.
 321                         --
 322                         -- NoRhs is also used for Insts like (CCallable f)
 323                         -- where no witness is required.
 324
 325   | Rhs                 -- Used when there is a RHS
 326         (TcExpr s)
 327         Bool            -- True => the RHS simply selects a superclass dictionary
 328                         --         from a subclass dictionary.
 329                         -- False => not so.
 330                         -- This is useful info, because superclass selection
 331                         -- is cheaper than building the dictionary using its dfun,
 332                         -- and we can sometimes replace the latter with the former
 333
 334   | PassiveScSel        -- Used for as-yet-unactivated RHSs.  For example suppose we have
 335                         -- an (Ord t) dictionary; then we put an (Eq t) entry in
 336                         -- the finite map, with an PassiveScSel.  Then if the
 337                         -- the (Eq t) binding is ever *needed* we make it an Rhs
 338         (TcExpr s)
 339         [Inst s]        -- List of Insts that are free in the RHS.
 340                         -- If the main Id is subsequently needed, we toss this list into
 341                         -- the needed-inst pool so that we make sure their bindings
 342                         -- will actually be produced.
 343                         --
 344                         -- Invariant: these Insts are already in the finite mapping
 345
 346
 347 pprAvails avails = vcat (map pp (eltsFM avails))
 348   where
 349     pp (Avail main_id rhs ids)
 350       = ppr main_id <> colon <+> brackets (ppr ids) <+> pprRhs rhs
 351
 352 pprRhs NoRhs = text "<no rhs>"
 353 pprRhs (Rhs rhs b) = ppr rhs
 354 pprRhs (PassiveScSel rhs is) = text "passive" <+> ppr rhs
 355 \end{code}
 356
 357
 358 %************************************************************************
 359 %*                                                                      *
 360 \subsection[reduce]{@reduce@}
 361 %*                                                                      *
 362 %************************************************************************
 363
 364 The main entry point for context reduction is @reduceContext@:
 365
 366 \begin{code}
 367 reduceContext :: SDoc -> (Inst s -> WhatToDo)
 368               -> [Inst s]       -- Given
 369               -> [Inst s]       -- Wanted
 370               -> TcM s (TcDictBinds s,
 371                         [Inst s],               -- Free
 372                         [Inst s])               -- Irreducible
 373
 374 reduceContext str try_me givens wanteds
 375   =     -- Zonking first
 376     mapNF_Tc zonkInst givens    `thenNF_Tc` \ givens ->
 377     mapNF_Tc zonkInst wanteds   `thenNF_Tc` \ wanteds ->
 378
 379 {-
 380     pprTrace "reduceContext" (vcat [
 381              text "----------------------",
 382              str,
 383              text "given" <+> ppr givens,
 384              text "wanted" <+> ppr wanteds,
 385              text "----------------------"
 386              ]) $
 387 -}
 388
 389         -- Build the Avail mapping from "givens"
 390     foldlNF_Tc addGiven emptyFM givens          `thenNF_Tc` \ avails ->
 391
 392         -- Do the real work
 393     reduce try_me wanteds (avails, [], [])      `thenTc` \ (avails, frees, irreds) ->
 394
 395         -- Extract the bindings from avails
 396     let
 397        binds = foldFM add_bind EmptyMonoBinds avails
 398
 399        add_bind _ (Avail main_id rhs ids) binds
 400          = foldr add_synonym (add_rhs_bind rhs binds) ids
 401          where
 402            add_rhs_bind (Rhs rhs _) binds = binds `AndMonoBinds` VarMonoBind main_id rhs
 403            add_rhs_bind other       binds = binds
 404
 405            -- Add the trivial {x = y} bindings
 406            -- The main Id can end up in the list when it's first added passively
 407            -- and then activated, so we have to filter it out.  A bit of a hack.
 408            add_synonym id binds
 409              | id /= main_id = binds `AndMonoBinds` VarMonoBind id (HsVar main_id)
 410              | otherwise     = binds
 411     in
 412 {-
 413     pprTrace ("reduceContext1") (vcat [
 414              text "----------------------",
 415              str,
 416              text "given" <+> ppr givens,
 417              text "wanted" <+> ppr wanteds,
 418              text "----",
 419              pprAvails avails,
 420              text "----------------------"
 421              ]) $
 422 -}
 423     returnTc (binds, frees, irreds)
 424 \end{code}
 425
 426 The main context-reduction function is @reduce@.  Here's its game plan.
 427
 428 \begin{code}
 429 reduce :: (Inst s -> WhatToDo)
 430        -> [Inst s]
 431        -> RedState s
 432        -> TcM s (RedState s)
 433 \end{code}
 434
 435 @reduce@ is passed
 436      try_me:    given an inst, this function returns
 437                   Reduce       reduce this
 438                   DontReduce   return this in "irreds"
 439                   Free         return this in "frees"
 440
 441      wanteds:   The list of insts to reduce
 442      state:     An accumulating parameter of type RedState
 443                 that contains the state of the algorithm
 444
 445   It returns a RedState.
 446
 447
 448 \begin{code}
 449     -- Base case: we're done!
 450 reduce try_me [] state = returnTc state
 451
 452 reduce try_me (wanted:wanteds) state@(avails, frees, irreds)
 453
 454     -- It's the same as an existing inst, or a superclass thereof
 455   | wanted `elemFM` avails
 456   = reduce try_me wanteds (activate avails wanted, frees, irreds)
 457
 458     -- It should be reduced
 459   | case try_me_result of { ReduceMe _ -> True; _ -> False }
 460   = lookupInst wanted         `thenNF_Tc` \ lookup_result ->
 461
 462     case lookup_result of
 463       GenInst wanteds' rhs -> use_instance wanteds' rhs
 464       SimpleInst rhs       -> use_instance []       rhs
 465
 466       NoInstance ->    -- No such instance!
 467                        -- Decide what to do based on the no_instance_action requested
 468                  case no_instance_action of
 469                    Stop        -> failTc        -- Fail
 470                    AddToIrreds -> add_to_irreds -- Add the offending insts to the irreds
 471
 472     -- It's free and this isn't a top-level binding, so just chuck it upstairs
 473   | case try_me_result of { Free -> True; _ -> False }
 474   =     -- First, see if the inst can be reduced to a constant in one step
 475     lookupInst wanted     `thenNF_Tc` \ lookup_result ->
 476     case lookup_result of
 477        SimpleInst rhs -> use_instance [] rhs
 478        other          -> add_to_frees
 479
 480     -- It's free and this is a top level binding, so
 481     -- check whether it's a tautology or not
 482   | case try_me_result of { FreeIfTautological -> True; _ -> False }
 483   =     -- Try for tautology
 484     tryTc
 485           -- If tautology trial fails, add to irreds
 486           (addGiven avails wanted      `thenNF_Tc` \ avails' ->
 487            returnTc (avails', frees, wanted:irreds))
 488
 489           -- If tautology succeeds, just add to frees
 490           (reduce try_me_taut [wanted] (avails, [], [])         `thenTc_`
 491            returnTc (avails, wanted:frees, irreds))
 492                                                                 `thenTc` \ state' ->
 493     reduce try_me wanteds state'
 494
 495
 496     -- It's irreducible (or at least should not be reduced)
 497   | otherwise
 498   = ASSERT( case try_me_result of { DontReduce -> True; other -> False } )
 499         -- See if the inst can be reduced to a constant in one step
 500     lookupInst wanted     `thenNF_Tc` \ lookup_result ->
 501     case lookup_result of
 502        SimpleInst rhs -> use_instance [] rhs
 503        other          -> add_to_irreds
 504
 505   where
 506         -- The three main actions
 507     add_to_frees  = reduce try_me wanteds (avails, wanted:frees, irreds)
 508
 509     add_to_irreds = addGiven avails wanted              `thenNF_Tc` \ avails' ->
 510                     reduce try_me wanteds (avails',  frees, wanted:irreds)
 511
 512     use_instance wanteds' rhs = addWanted avails wanted rhs     `thenNF_Tc` \ avails' ->
 513                                 reduce try_me (wanteds' ++ wanteds) (avails', frees, irreds)
 514
 515
 516     try_me_result               = try_me wanted
 517     ReduceMe no_instance_action = try_me_result
 518
 519     -- The try-me to use when trying to identify tautologies
 520     -- It blunders on reducing as much as possible
 521     try_me_taut inst = ReduceMe Stop    -- No error recovery
 522 \end{code}
 523
 524
 525 \begin{code}
 526 activate :: Avails s -> Inst s -> Avails s
 527          -- Activate the binding for Inst, ensuring that a binding for the
 528          -- wanted Inst will be generated.
 529          -- (Activate its parent if necessary, recursively).
 530          -- Precondition: the Inst is in Avails already
 531
 532 activate avails wanted
 533   | not (instBindingRequired wanted)
 534   = avails
 535
 536   | otherwise
 537   = case lookupFM avails wanted of
 538
 539       Just (Avail main_id (PassiveScSel rhs insts) ids) ->
 540                foldl activate avails' insts      -- Activate anything it needs
 541              where
 542                avails' = addToFM avails wanted avail'
 543                avail'  = Avail main_id (Rhs rhs True) (wanted_id : ids) -- Activate it
 544
 545       Just (Avail main_id other_rhs ids) -> -- Just add to the synonyms list
 546                addToFM avails wanted (Avail main_id other_rhs (wanted_id : ids))
 547
 548       Nothing -> panic "activate"
 549   where
 550       wanted_id = instToId wanted
 551
 552 addWanted avails wanted rhs_expr
 553   = ASSERT( not (wanted `elemFM` avails) )
 554     returnNF_Tc (addToFM avails wanted avail)
 555         -- NB: we don't add the thing's superclasses too!
 556         -- Why not?  Because addWanted is used when we've successfully used an
 557         -- instance decl to reduce something; e.g.
 558         --      d:Ord [a] = dfunOrd (d1:Eq [a]) (d2:Ord a)
 559         -- Note that we pass the superclasses to the dfun, so they will be "wanted".
 560         -- If we put the superclasses of "d" in avails, then we might end up
 561         -- expressing "d1" in terms of "d", which would be a disaster.
 562   where
 563     avail = Avail (instToId wanted) rhs []
 564
 565     rhs | instBindingRequired wanted = Rhs rhs_expr False       -- Not superclass selection
 566         | otherwise                  = NoRhs
 567
 568 addGiven :: Avails s -> Inst s -> NF_TcM s (Avails s)
 569 addGiven avails given
 570   =      -- ASSERT( not (given `elemFM` avails) )
 571          -- This assertion isn' necessarily true.  It's permitted
 572          -- to given a redundant context in a type signature (eg (Ord a, Eq a) => ...)
 573          -- and when typechecking instance decls we generate redundant "givens" too.
 574     addAvail avails given avail
 575   where
 576     avail = Avail (instToId given) NoRhs []
 577
 578 addAvail avails wanted avail
 579   = addSuperClasses (addToFM avails wanted avail) wanted
 580
 581 addSuperClasses :: Avails s -> Inst s -> NF_TcM s (Avails s)
 582                 -- Add all the superclasses of the Inst to Avails
 583                 -- Invariant: the Inst is already in Avails.
 584
 585 addSuperClasses avails dict
 586   | not (isDict dict)
 587   = returnNF_Tc avails
 588
 589   | otherwise   -- It is a dictionary
 590   = tcInstTheta env sc_theta            `thenNF_Tc` \ sc_theta' ->
 591     foldlNF_Tc add_sc avails (zipEqual "addSuperClasses" sc_theta' sc_sels)
 592   where
 593     (clas, tys) = getDictClassTys dict
 594
 595     (tyvars, sc_theta, sc_sels, _, _) = classBigSig clas
 596     env       = zipTyVarEnv tyvars tys
 597
 598     add_sc avails ((super_clas, super_tys), sc_sel)
 599       = newDictFromOld dict super_clas super_tys        `thenNF_Tc` \ super_dict ->
 600         let
 601            sc_sel_rhs = DictApp (TyApp (HsVar (RealId sc_sel))
 602                                        tys)
 603                                 [instToId dict]
 604         in
 605         case lookupFM avails super_dict of
 606
 607              Just (Avail main_id (Rhs rhs False {- not sc selection -}) ids) ->
 608                   -- Already there, but not as a superclass selector
 609                   -- No need to look at its superclasses; since it's there
 610                   --    already they must be already in avails
 611                   -- However, we must remember to activate the dictionary
 612                   -- from which it is (now) generated
 613                   returnNF_Tc (activate avails' dict)
 614                 where
 615                   avails' = addToFM avails super_dict avail
 616                   avail   = Avail main_id (Rhs sc_sel_rhs True) ids     -- Superclass selection
 617
 618              Just (Avail _ _ _) -> returnNF_Tc avails
 619                   -- Already there; no need to do anything
 620
 621              Nothing ->
 622                   -- Not there at all, so add it, and its superclasses
 623                   addAvail avails super_dict avail
 624                 where
 625                   avail   = Avail (instToId super_dict)
 626                                   (PassiveScSel sc_sel_rhs [dict])
 627                                   []
 628 \end{code}
 629
 630 %************************************************************************
 631 %*                                                                      *
 632 \subsection[simple]{@Simple@ versions}
 633 %*                                                                      *
 634 %************************************************************************
 635
 636 Much simpler versions when there are no bindings to make!
 637
 638 @tcSimplifyThetas@ simplifies class-type constraints formed by
 639 @deriving@ declarations and when specialising instances.  We are
 640 only interested in the simplified bunch of class/type constraints.
 641
 642 It simplifies to constraints of the form (C a b c) where
 643 a,b,c are type variables.  This is required for the context of
 644 instance declarations.
 645
 646 \begin{code}
 647 tcSimplifyThetas :: (Class -> ClassInstEnv)             -- How to find the ClassInstEnv
 648                  -> ThetaType                           -- Wanted
 649                  -> TcM s ThetaType                     -- Needed; of the form C a b c
 650                                                         -- where a,b,c are type variables
 651
 652 tcSimplifyThetas inst_mapper wanteds
 653   = reduceSimple inst_mapper [] wanteds         `thenNF_Tc` \ irreds ->
 654     let
 655         -- Check that the returned dictionaries are of the form (C a b c)
 656         bad_guys = [ct | ct@(clas,tys) <- irreds, not (all isTyVarTy tys)]
 657     in
 658     if null bad_guys then
 659         returnTc irreds
 660     else
 661        mapNF_Tc addNoInstErr bad_guys           `thenNF_Tc_`
 662        failTc
 663 \end{code}
 664
 665 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
 666 used with \tr{default} declarations.  We are only interested in
 667 whether it worked or not.
 668
 669 \begin{code}
 670 tcSimplifyCheckThetas :: ThetaType      -- Given
 671                       -> ThetaType      -- Wanted
 672                       -> TcM s ()
 673
 674 tcSimplifyCheckThetas givens wanteds
 675   = reduceSimple classInstEnv givens wanteds    `thenNF_Tc`     \ irreds ->
 676     if null irreds then
 677        returnTc ()
 678     else
 679        mapNF_Tc addNoInstErr irreds             `thenNF_Tc_`
 680        failTc
 681 \end{code}
 682
 683
 684 \begin{code}
 685 type AvailsSimple = FiniteMap (Class, [TauType]) Bool
 686                     -- True  => irreducible
 687                     -- False => given, or can be derived from a given or from an irreducible
 688
 689 reduceSimple :: (Class -> ClassInstEnv)
 690              -> ThetaType               -- Given
 691              -> ThetaType               -- Wanted
 692              -> NF_TcM s ThetaType      -- Irreducible
 693
 694 reduceSimple inst_mapper givens wanteds
 695   = reduce_simple inst_mapper givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
 696     returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
 697   where
 698     givens_fm     = foldl addNonIrred emptyFM givens
 699
 700 reduce_simple :: (Class -> ClassInstEnv)
 701               -> AvailsSimple
 702               -> ThetaType
 703               -> NF_TcM s AvailsSimple
 704
 705 reduce_simple inst_mapper givens []
 706   =          -- Finished, so pull out the needed ones
 707     returnNF_Tc givens
 708
 709 reduce_simple inst_mapper givens (wanted@(clas,tys) : wanteds)
 710   | wanted `elemFM` givens
 711   = reduce_simple inst_mapper givens wanteds
 712
 713   | otherwise
 714   = lookupSimpleInst (inst_mapper clas) clas tys        `thenNF_Tc` \ maybe_theta ->
 715
 716     case maybe_theta of
 717       Nothing ->    reduce_simple inst_mapper (addIrred    givens wanted) wanteds
 718       Just theta -> reduce_simple inst_mapper (addNonIrred givens wanted) (theta ++ wanteds)
 719
 720 addIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
 721 addIrred givens ct
 722   = addSCs (addToFM givens ct True) ct
 723
 724 addNonIrred :: AvailsSimple -> (Class, [TauType]) -> AvailsSimple
 725 addNonIrred givens ct
 726   = addSCs (addToFM givens ct False) ct
 727
 728 addSCs givens ct@(clas,tys)
 729  = foldl add givens sc_theta
 730  where
 731    (tyvars, sc_theta_tmpl, _, _, _) = classBigSig clas
 732    sc_theta = instantiateThetaTy (zipTyVarEnv tyvars tys) sc_theta_tmpl
 733
 734    add givens ct = case lookupFM givens ct of
 735                            Nothing    -> -- Add it and its superclasses
 736                                          addSCs (addToFM givens ct False) ct
 737
 738                            Just True  -> -- Set its flag to False; superclasses already done
 739                                          addToFM givens ct False
 740
 741                            Just False -> -- Already done
 742                                          givens
 743
 744 \end{code}
 745
 746 %************************************************************************
 747 %*                                                                      *
 748 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
 749 %*                                                                      *
 750 %************************************************************************
 751
 752 When doing a binding group, we may have @Insts@ of local functions.
 753 For example, we might have...
 754 \begin{verbatim}
 755 let f x = x + 1     -- orig local function (overloaded)
 756     f.1 = f Int     -- two instances of f
 757     f.2 = f Float
 758  in
 759     (f.1 5, f.2 6.7)
 760 \end{verbatim}
 761 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
 762 where @f@ is in scope; those @Insts@ must certainly not be passed
 763 upwards towards the top-level.  If the @Insts@ were binding-ified up
 764 there, they would have unresolvable references to @f@.
 765
 766 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
 767 For each method @Inst@ in the @init_lie@ that mentions one of the
 768 @Ids@, we create a binding.  We return the remaining @Insts@ (in an
 769 @LIE@), as well as the @HsBinds@ generated.
 770
 771 \begin{code}
 772 bindInstsOfLocalFuns :: LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s)
 773
 774 bindInstsOfLocalFuns init_lie local_ids
 775   = reduceContext (text "bindInsts" <+> ppr local_ids)
 776                   try_me [] (bagToList init_lie)        `thenTc` \ (binds, frees, irreds) ->
 777     ASSERT( null irreds )
 778     returnTc (mkLIE frees, binds)
 779   where
 780     local_id_set = mkIdSet local_ids    -- There can occasionally be a lot of them
 781                                         -- so it's worth building a set, so that
 782                                         -- lookup (in isMethodFor) is faster
 783     try_me inst | isMethodFor local_id_set inst = ReduceMe AddToIrreds
 784                 | otherwise                     = Free
 785 \end{code}
 786
 787
 788 %************************************************************************
 789 %*                                                                      *
 790 \section[Disambig]{Disambiguation of overloading}
 791 %*                                                                      *
 792 %************************************************************************
 793
 794
 795 If a dictionary constrains a type variable which is
 796 \begin{itemize}
 797 \item
 798 not mentioned in the environment
 799 \item
 800 and not mentioned in the type of the expression
 801 \end{itemize}
 802 then it is ambiguous. No further information will arise to instantiate
 803 the type variable; nor will it be generalised and turned into an extra
 804 parameter to a function.
 805
 806 It is an error for this to occur, except that Haskell provided for
 807 certain rules to be applied in the special case of numeric types.
 808
 809 Specifically, if
 810 \begin{itemize}
 811 \item
 812 at least one of its classes is a numeric class, and
 813 \item
 814 all of its classes are numeric or standard
 815 \end{itemize}
 816 then the type variable can be defaulted to the first type in the
 817 default-type list which is an instance of all the offending classes.
 818
 819 So here is the function which does the work.  It takes the ambiguous
 820 dictionaries and either resolves them (producing bindings) or
 821 complains.  It works by splitting the dictionary list by type
 822 variable, and using @disambigOne@ to do the real business.
 823
 824
 825 @tcSimplifyTop@ is called once per module to simplify
 826 all the constant and ambiguous Insts.
 827
 828 \begin{code}
 829 tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s)
 830 tcSimplifyTop wanted_lie
 831   = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) ->
 832     ASSERT( null frees )
 833
 834     let
 835                 -- All the non-std ones are definite errors
 836         (stds, non_stds) = partition isStdClassTyVarDict irreds
 837
 838
 839                 -- Group by type variable
 840         std_groups = equivClasses cmp_by_tyvar stds
 841
 842                 -- Pick the ones which its worth trying to disambiguate
 843         (std_oks, std_bads) = partition worth_a_try std_groups
 844                 -- Have a try at disambiguation
 845                 -- if the type variable isn't bound
 846                 -- up with one of the non-standard classes
 847         worth_a_try group@(d:_) = isEmptyTyVarSet (tyVarsOfInst d `intersectTyVarSets` non_std_tyvars)
 848         non_std_tyvars          = unionManyTyVarSets (map tyVarsOfInst non_stds)
 849
 850                 -- Collect together all the bad guys
 851         bad_guys = non_stds ++ concat std_bads
 852     in
 853
 854         -- Disambiguate the ones that look feasible
 855     mapTc disambigGroup std_oks         `thenTc` \ binds_ambig ->
 856
 857         -- And complain about the ones that don't
 858     mapNF_Tc complain bad_guys          `thenNF_Tc_`
 859
 860     returnTc (binds1 `AndMonoBinds` andMonoBinds binds_ambig)
 861   where
 862     wanteds     = bagToList wanted_lie
 863     try_me inst = ReduceMe AddToIrreds
 864
 865     d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2
 866
 867     complain d | isEmptyTyVarSet (tyVarsOfInst d) = addTopInstanceErr d
 868                | otherwise                        = addAmbigErr [d]
 869
 870 get_tv d   = case getDictClassTys d of
 871                    (clas, [ty]) -> getTyVar "tcSimplifyTop" ty
 872 get_clas d = case getDictClassTys d of
 873                    (clas, [ty]) -> clas
 874 \end{code}
 875
 876 @disambigOne@ assumes that its arguments dictionaries constrain all
 877 the same type variable.
 878
 879 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
 880 @()@ instead of @Int@.  I reckon this is the Right Thing to do since
 881 the most common use of defaulting is code like:
 882 \begin{verbatim}
 883         _ccall_ foo     `seqPrimIO` bar
 884 \end{verbatim}
 885 Since we're not using the result of @foo@, the result if (presumably)
 886 @void@.
 887
 888 \begin{code}
 889 disambigGroup :: [Inst s]       -- All standard classes of form (C a)
 890               -> TcM s (TcDictBinds s)
 891
 892 disambigGroup dicts
 893   |  any isNumericClass classes         -- Guaranteed all standard classes
 894   =     -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
 895         -- SO, TRY DEFAULT TYPES IN ORDER
 896
 897         -- Failure here is caused by there being no type in the
 898         -- default list which can satisfy all the ambiguous classes.
 899         -- For example, if Real a is reqd, but the only type in the
 900         -- default list is Int.
 901     tcGetDefaultTys                     `thenNF_Tc` \ default_tys ->
 902     let
 903       try_default []    -- No defaults work, so fail
 904         = failTc
 905
 906       try_default (default_ty : default_tys)
 907         = tryTc (try_default default_tys) $     -- If default_ty fails, we try
 908                                                 -- default_tys instead
 909           tcSimplifyCheckThetas [] thetas       `thenTc` \ _ ->
 910           returnTc default_ty
 911         where
 912           thetas = classes `zip` repeat [default_ty]
 913     in
 914         -- See if any default works, and if so bind the type variable to it
 915         -- If not, add an AmbigErr
 916     recoverTc (addAmbigErr dicts `thenNF_Tc_` returnTc EmptyMonoBinds)  $
 917
 918     try_default default_tys                     `thenTc` \ chosen_default_ty ->
 919
 920         -- Bind the type variable and reduce the context, for real this time
 921     tcInstType emptyTyVarEnv chosen_default_ty          `thenNF_Tc` \ chosen_default_tc_ty ->   -- Tiresome!
 922     unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar)   `thenTc_`
 923     reduceContext (text "disambig" <+> ppr dicts)
 924                   try_me [] dicts       `thenTc` \ (binds, frees, ambigs) ->
 925     ASSERT( null frees && null ambigs )
 926     returnTc binds
 927
 928   | all isCcallishClass classes
 929   =     -- Default CCall stuff to (); we don't even both to check that () is an
 930         -- instance of CCallable/CReturnable, because we know it is.
 931     unifyTauTy (mkTyVarTy tyvar) unitTy    `thenTc_`
 932     returnTc EmptyMonoBinds
 933
 934   | otherwise -- No defaults
 935   = addAmbigErr dicts   `thenNF_Tc_`
 936     returnTc EmptyMonoBinds
 937
 938   where
 939     try_me inst = ReduceMe AddToIrreds          -- This reduce should not fail
 940     tyvar       = get_tv (head dicts)           -- Should be non-empty
 941     classes     = map get_clas dicts
 942 \end{code}
 943
 944
 945
 946 Errors and contexts
 947 ~~~~~~~~~~~~~~~~~~~
 948 ToDo: for these error messages, should we note the location as coming
 949 from the insts, or just whatever seems to be around in the monad just
 950 now?
 951
 952 \begin{code}
 953 genCantGenErr insts     -- Can't generalise these Insts
 954   = sep [ptext SLIT("Cannot generalise these overloadings (in a _ccall_):"),
 955          nest 4 (pprInstsInFull insts)
 956         ]
 957
 958 addAmbigErr dicts
 959   = tcAddSrcLoc (instLoc (head dicts)) $
 960     addErrTc (sep [text "Cannot resolve the ambiguous context" <+> pprInsts dicts,
 961                    nest 4 (pprInstsInFull dicts)])
 962
 963 -- Used for top-level irreducibles
 964 addTopInstanceErr dict
 965   = tcAddSrcLoc (instLoc dict)                 $
 966     addErrTc (sep [ptext SLIT("No instance for") <+> quotes (pprInst dict),
 967                    nest 4 $ parens $ pprOrigin dict])
 968
 969 addNoInstanceErr str givens dict
 970   = tcAddSrcLoc (instLoc dict) $
 971     addErrTc (sep [sep [ptext SLIT("Could not deduce") <+> quotes (pprInst dict),
 972                         nest 4 $ parens $ pprOrigin dict],
 973                    nest 4 $ ptext SLIT("from the context") <+> pprInsts givens]
 974               $$
 975               ptext SLIT("Probable cause:") <+>
 976               vcat [ptext SLIT("missing") <+> quotes (pprInst dict) <+> ptext SLIT("in") <+> str,
 977                     if all_tyvars then empty else
 978                     ptext SLIT("or missing instance declaration for") <+> quotes (pprInst dict)]
 979     )
 980   where
 981     all_tyvars = all isTyVarTy tys
 982     (_, tys)   = getDictClassTys dict
 983
 984 -- Used for the ...Thetas variants; all top level
 985 addNoInstErr (c,ts)
 986   = addErrTc (ptext SLIT("No instance for") <+> quotes (pprConstraint c ts))
 987 \end{code}