ghc/compiler/typecheck/TcSimplify.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
   3 %
   4 \section[TcSimplify]{TcSimplify}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcSimplify (
  10         tcSimplify, tcSimplifyAndCheck, tcSimplifyWithExtraGlobals,
  11         tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, tcSimplifyRank2,
  12         bindInstsOfLocalFuns
  13     ) where
  14
  15 import Ubiq
  16
  17 import HsSyn            ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit,
  18                           Match, HsBinds, Qual, PolyType, ArithSeqInfo,
  19                           GRHSsAndBinds, Stmt, Fake )
  20 import TcHsSyn          ( TcIdOcc(..), TcIdBndr(..), TcExpr(..), TcMonoBinds(..) )
  21
  22 import TcMonad          hiding ( rnMtoTcM )
  23 import Inst             ( lookupInst, tyVarsOfInst, isTyVarDict, isDict, matchesInst,
  24                           instToId, instBindingRequired, instCanBeGeneralised, newDictsAtLoc,
  25                           Inst(..), LIE(..), zonkLIE, emptyLIE, plusLIE, unitLIE, consLIE,
  26                           InstOrigin(..), OverloadedLit )
  27 import TcEnv            ( tcGetGlobalTyVars )
  28 import TcType           ( TcType(..), TcTyVar(..), TcTyVarSet(..), TcMaybe, tcInstType )
  29 import Unify            ( unifyTauTy )
  30
  31 import Bag              ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList,
  32                           snocBag, consBag, unionBags, isEmptyBag )
  33 import Class            ( isNumericClass, isStandardClass, isCcallishClass,
  34                           isSuperClassOf, classSuperDictSelId
  35                         )
  36 import Id               ( GenId )
  37 import Maybes           ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool, Maybe(..) )
  38 import Outputable       ( Outputable(..){-instance * []-} )
  39 import PprStyle--ToDo:rm
  40 import PprType          ( GenType, GenTyVar, GenClass{-instance Outputable;ToDo:rm-} )
  41 import Pretty
  42 import SrcLoc           ( mkUnknownSrcLoc )
  43 import Util
  44 import Type             ( GenType, Type(..), TauType(..), mkTyVarTy, getTyVar, eqSimpleTy )
  45 import TysWiredIn       ( intTy )
  46 import TyVar            ( GenTyVar, GenTyVarSet(..),
  47                           elementOfTyVarSet, emptyTyVarSet, unionTyVarSets,
  48                           isEmptyTyVarSet, tyVarSetToList )
  49 import Unique           ( Unique )
  50 \end{code}
  51
  52
  53 %************************************************************************
  54 %*                                                                      *
  55 \subsection[tcSimplify-main]{Main entry function}
  56 %*                                                                      *
  57 %************************************************************************
  58
  59 * May modify the substitution to bind ambiguous type variables.
  60
  61 Specification
  62 ~~~~~~~~~~~~~
  63 (1) If an inst constrains only ``global'' type variables, (or none),
  64     return it as a ``global'' inst.
  65
  66 OTHERWISE
  67
  68 (2) Simplify it repeatedly (checking for (1) of course) until it is a dict
  69     constraining only a type variable.
  70
  71 (3) If it constrains a ``local'' type variable, return it as a ``local'' inst.
  72     Otherwise it must be ambiguous, so try to resolve the ambiguity.
  73
  74
  75 \begin{code}
  76 tcSimpl :: Bool                         -- True <=> simplify const insts
  77         -> TcTyVarSet s                 -- ``Global'' type variables
  78         -> TcTyVarSet s                 -- ``Local''  type variables
  79                                         -- ASSERT: both these tyvar sets are already zonked
  80         -> LIE s                        -- Given; these constrain only local tyvars
  81         -> LIE s                        -- Wanted
  82         -> TcM s (LIE s,                        -- Free
  83                   [(TcIdOcc s,TcExpr s)],       -- Bindings
  84                   LIE s)                        -- Remaining wanteds; no dups
  85
  86 tcSimpl squash_consts global_tvs local_tvs givens wanteds
  87   =     -- ASSSERT: global_tvs and local_tvs are already zonked
  88         -- Make sure the insts fixed points of the substitution
  89     zonkLIE givens                      `thenNF_Tc` \ givens ->
  90     zonkLIE wanteds                     `thenNF_Tc` \ wanteds ->
  91
  92         -- Deal with duplicates and type constructors
  93     elimTyCons
  94          squash_consts (\tv -> tv `elementOfTyVarSet` global_tvs)
  95          givens wanteds         `thenTc` \ (globals, tycon_binds, locals_and_ambigs) ->
  96
  97         -- Now disambiguate if necessary
  98     let
  99         ambigs = filterBag is_ambiguous locals_and_ambigs
 100     in
 101     if not (isEmptyBag ambigs) then
 102         -- Some ambiguous dictionaries.  We now disambiguate them,
 103         -- which binds the offending type variables to suitable types in the
 104         -- substitution, and then we retry the whole process.  This
 105         -- time there won't be any ambiguous ones.
 106         -- There's no need to back-substitute on global and local tvs,
 107         -- because the ambiguous type variables can't be in either.
 108
 109         -- Why do we retry the whole process?  Because binding a type variable
 110         -- to a particular type might enable a short-cut simplification which
 111         -- elimTyCons will have missed the first time.
 112
 113         disambiguateDicts ambigs                `thenTc_`
 114         tcSimpl squash_consts global_tvs local_tvs givens wanteds
 115
 116     else
 117         -- No ambiguous dictionaries.  Just bash on with the results
 118         -- of the elimTyCons
 119
 120         -- Check for non-generalisable insts
 121     let
 122         locals          = locals_and_ambigs     -- ambigs is empty
 123         cant_generalise = filterBag (not . instCanBeGeneralised) locals
 124     in
 125     checkTc (isEmptyBag cant_generalise)
 126             (genCantGenErr cant_generalise)     `thenTc_`
 127
 128
 129         -- Deal with superclass relationships
 130     elimSCs givens locals               `thenNF_Tc` \ (sc_binds, locals2) ->
 131
 132          -- Finished
 133     returnTc (globals, bagToList (sc_binds `unionBags` tycon_binds), locals2)
 134   where
 135     is_ambiguous (Dict _ _ ty _ _)
 136         = not (getTyVar "is_ambiguous" ty `elementOfTyVarSet` local_tvs)
 137 \end{code}
 138
 139 The main wrapper is @tcSimplify@.  It just calls @tcSimpl@, but with
 140 the ``don't-squash-consts'' flag set depending on top-level ness.  For
 141 top level defns we *do* squash constants, so that they stay local to a
 142 single defn.  This makes things which are inlined more likely to be
 143 exportable, because their constants are "inside".  Later passes will
 144 float them out if poss, after inlinings are sorted out.
 145
 146 \begin{code}
 147 tcSimplify
 148         :: TcTyVarSet s                 -- ``Local''  type variables
 149         -> LIE s                        -- Wanted
 150         -> TcM s (LIE s,                        -- Free
 151                   [(TcIdOcc s,TcExpr s)],       -- Bindings
 152                   LIE s)                        -- Remaining wanteds; no dups
 153
 154 tcSimplify local_tvs wanteds
 155   = tcGetGlobalTyVars                   `thenNF_Tc` \ global_tvs ->
 156     tcSimpl False global_tvs local_tvs emptyBag wanteds
 157 \end{code}
 158
 159 @tcSimplifyWithExtraGlobals@ is just like @tcSimplify@ except that you get
 160 to specify some extra global type variables that the simplifer will treat
 161 as free in the environment.
 162
 163 \begin{code}
 164 tcSimplifyWithExtraGlobals
 165         :: TcTyVarSet s                 -- Extra ``Global'' type variables
 166         -> TcTyVarSet s                 -- ``Local''  type variables
 167         -> LIE s                        -- Wanted
 168         -> TcM s (LIE s,                        -- Free
 169                   [(TcIdOcc s,TcExpr s)],       -- Bindings
 170                   LIE s)                        -- Remaining wanteds; no dups
 171
 172 tcSimplifyWithExtraGlobals extra_global_tvs local_tvs wanteds
 173   = tcGetGlobalTyVars                   `thenNF_Tc` \ global_tvs ->
 174     tcSimpl False
 175             (global_tvs `unionTyVarSets` extra_global_tvs)
 176             local_tvs emptyBag wanteds
 177 \end{code}
 178
 179 @tcSimplifyAndCheck@ is similar to the above, except that it checks
 180 that there is an empty wanted-set at the end.  It may still return
 181 some of constant insts, which have to be resolved finally at the end.
 182
 183 \begin{code}
 184 tcSimplifyAndCheck
 185          :: TcTyVarSet s                -- ``Local''  type variables; ASSERT is fixpoint
 186          -> LIE s                       -- Given
 187          -> LIE s                       -- Wanted
 188          -> TcM s (LIE s,                       -- Free
 189                    [(TcIdOcc s,TcExpr s)])      -- Bindings
 190
 191 tcSimplifyAndCheck local_tvs givens wanteds
 192   = tcGetGlobalTyVars                   `thenNF_Tc` \ global_tvs ->
 193     tcSimpl False global_tvs local_tvs
 194             givens wanteds              `thenTc` \ (free_insts, binds, wanteds') ->
 195     checkTc (isEmptyBag wanteds')
 196             (reduceErr wanteds')        `thenTc_`
 197     returnTc (free_insts, binds)
 198 \end{code}
 199
 200 @tcSimplifyRank2@ checks that the argument of a rank-2 polymorphic function
 201 is not overloaded.
 202
 203 \begin{code}
 204 tcSimplifyRank2 :: TcTyVarSet s         -- ``Local'' type variables; ASSERT is fixpoint
 205                 -> LIE s                -- Given
 206                 -> TcM s (LIE s,                        -- Free
 207                           [(TcIdOcc s,TcExpr s)])       -- Bindings
 208
 209
 210 tcSimplifyRank2 local_tvs givens
 211   = zonkLIE givens                      `thenNF_Tc` \ givens' ->
 212     elimTyCons True
 213                (\tv -> not (tv `elementOfTyVarSet` local_tvs))
 214                 -- This predicate claims that all
 215                 -- any non-local tyvars are global,
 216                 -- thereby postponing dealing with
 217                 -- ambiguity until the enclosing Gen
 218                emptyLIE givens' `thenTc` \ (free, dict_binds, wanteds) ->
 219
 220     checkTc (isEmptyBag wanteds) (reduceErr wanteds)    `thenTc_`
 221
 222     returnTc (free, bagToList dict_binds)
 223 \end{code}
 224
 225 @tcSimplifyTop@ deals with constant @Insts@, using the standard simplification
 226 mechansim with the extra flag to say ``beat out constant insts''.
 227
 228 \begin{code}
 229 tcSimplifyTop :: LIE s -> TcM s [(TcIdOcc s, TcExpr s)]
 230 tcSimplifyTop dicts
 231   = tcGetGlobalTyVars                                           `thenNF_Tc` \ global_tvs ->
 232     tcSimpl True emptyTyVarSet emptyTyVarSet emptyBag dicts     `thenTc` \ (_, binds, _) ->
 233     returnTc binds
 234 \end{code}
 235
 236 @tcSimplifyThetas@ simplifies class-type constraints formed by
 237 @deriving@ declarations and when specialising instances.  We are
 238 only interested in the simplified bunch of class/type constraints.
 239
 240 \begin{code}
 241 tcSimplifyThetas :: (Class -> TauType -> InstOrigin s)  -- Creates an origin for the dummy dicts
 242                  -> [(Class, TauType)]                -- Simplify this
 243                  -> TcM s [(Class, TauType)]          -- Result
 244
 245 tcSimplifyThetas = panic "tcSimplifyThetas"
 246
 247 {-      LATER
 248 tcSimplifyThetas mk_inst_origin theta
 249   = let
 250         dicts = listToBag (map mk_dummy_dict theta)
 251     in
 252          -- Do the business (this is just the heart of "tcSimpl")
 253     elimTyCons True (\tv -> False) emptyLIE dicts    `thenTc`   \ (_, _, dicts2) ->
 254
 255           -- Deal with superclass relationships
 256     elimSCs [] dicts2               `thenNF_Tc` \ (_, dicts3) ->
 257
 258     returnTc (map unmk_dummy_dict (bagToList dicts3))
 259   where
 260     mk_dummy_dict (clas, ty) = Dict uniq clas ty (mk_inst_origin clas ty) mkUnknownSrcLoc
 261     uniq                     = panic "tcSimplifyThetas:uniq"
 262
 263     unmk_dummy_dict (Dict _ clas ty _ _) = (clas, ty)
 264 -}
 265 \end{code}
 266
 267 @tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
 268 used with \tr{default} declarations.  We are only interested in
 269 whether it worked or not.
 270
 271 \begin{code}
 272 tcSimplifyCheckThetas :: InstOrigin s           -- context; for error msg
 273                       -> [(Class, TauType)]     -- Simplify this
 274                       -> TcM s ()
 275
 276 tcSimplifyCheckThetas x y = _trace "tcSimplifyCheckThetas: does nothing" $
 277                         returnTc ()
 278
 279 {-      LATER
 280 tcSimplifyCheckThetas origin theta
 281   = let
 282         dicts = map mk_dummy_dict theta
 283     in
 284          -- Do the business (this is just the heart of "tcSimpl")
 285     elimTyCons True (\tv -> False) emptyLIE dicts    `thenTc`   \ _ ->
 286
 287     returnTc ()
 288   where
 289     mk_dummy_dict (clas, ty)
 290       = Dict uniq clas ty origin mkUnknownSrcLoc
 291
 292     uniq = panic "tcSimplifyCheckThetas:uniq"
 293 -}
 294 \end{code}
 295
 296
 297 %************************************************************************
 298 %*                                                                      *
 299 \subsection[elimTyCons]{@elimTyCons@}
 300 %*                                                                      *
 301 %************************************************************************
 302
 303 \begin{code}
 304 elimTyCons :: Bool                              -- True <=> Simplify const insts
 305            -> (TcTyVar s -> Bool)               -- Free tyvar predicate
 306            -> LIE s                             -- Given
 307            -> LIE s                             -- Wanted
 308            -> TcM s (LIE s,                     -- Free
 309                      Bag (TcIdOcc s, TcExpr s), -- Bindings
 310                      LIE s                      -- Remaining wanteds; no dups;
 311                                                 -- dicts only (no Methods)
 312                )
 313 \end{code}
 314
 315 The bindings returned may mention any or all of ``givens'', so the
 316 order in which the generated binds are put together is {\em tricky}.
 317 Case~4 of @try@ is the general case to see.
 318
 319 When we do @eTC givens (wanted:wanteds)@ [some details omitted], we...
 320
 321     (1) first look up @wanted@; this gives us one binding to heave in:
 322             wanted = rhs
 323
 324     (2) step (1) also gave us some @simpler_wanteds@; we simplify
 325         these and get some (simpler-wanted-)bindings {\em that must be
 326         in scope} for the @wanted=rhs@ binding above!
 327
 328     (3) we simplify the remaining @wanteds@ (recursive call), giving
 329         us yet more bindings.
 330
 331 The final arrangement of the {\em non-recursive} bindings is
 332
 333     let <simpler-wanted-binds> in
 334     let wanted = rhs           in
 335     let <yet-more-bindings> ...
 336
 337 \begin{code}
 338 elimTyCons squash_consts is_free_tv givens wanteds
 339   = eTC givens (bagToList wanteds)      `thenTc` \ (_, free, binds, irreds) ->
 340     returnTc (free,binds,irreds)
 341   where
 342 --    eTC :: LIE s -> [Inst s]
 343 --        -> TcM s (LIE s, LIE s, Bag (TcIdOcc s, TcExpr s), LIE s)
 344
 345     eTC givens [] = returnTc (givens, emptyBag, emptyBag, emptyBag)
 346
 347     eTC givens (wanted:wanteds)
 348     -- Case 0: same as an existing inst
 349       | maybeToBool maybe_equiv
 350       = eTC givens wanteds      `thenTc` \ (givens1, frees, binds, irreds) ->
 351         let
 352           -- Create a new binding iff it's needed
 353           this = expectJust "eTC" maybe_equiv
 354           new_binds | instBindingRequired wanted = (instToId wanted, HsVar (instToId this))
 355                                                    `consBag` binds
 356                     | otherwise                  = binds
 357         in
 358         returnTc (givens1, frees, new_binds, irreds)
 359
 360     -- Case 1: constrains no type variables at all
 361     -- In this case we have a quick go to see if it has an
 362     -- instance which requires no inputs (ie a constant); if so we use
 363     -- it; if not, we give up on the instance and just heave it out the
 364     -- top in the free result
 365       | isEmptyTyVarSet tvs_of_wanted
 366       = simplify_it squash_consts       {- If squash_consts is false,
 367                                            simplify only if trival -}
 368                     givens wanted wanteds
 369
 370     -- Case 2: constrains free vars only, so fling it out the top in free_ids
 371       | all is_free_tv (tyVarSetToList tvs_of_wanted)
 372       = eTC (wanted `consBag` givens) wanteds   `thenTc` \ (givens1, frees, binds, irreds) ->
 373         returnTc (givens1, wanted `consBag` frees, binds, irreds)
 374
 375     -- Case 3: is a dict constraining only a tyvar,
 376     -- so return it as part of the "wanteds" result
 377       | isTyVarDict wanted
 378       = eTC (wanted `consBag` givens) wanteds   `thenTc` \ (givens1, frees, binds, irreds) ->
 379         returnTc (givens1, frees, binds, wanted `consBag` irreds)
 380
 381     -- Case 4: is not a simple dict, so look up in instance environment
 382       | otherwise
 383       = simplify_it True {- Simplify even if not trivial -}
 384                     givens wanted wanteds
 385       where
 386         tvs_of_wanted  = tyVarsOfInst wanted
 387
 388         -- Look for something in "givens" that matches "wanted"
 389         Just the_equiv = maybe_equiv
 390         maybe_equiv    = foldBag seqMaybe try Nothing givens
 391         try given | wanted `matchesInst` given = Just given
 392                   | otherwise                  = Nothing
 393
 394
 395     simplify_it simplify_always givens wanted wanteds
 396         -- Recover immediately on no-such-instance errors
 397       = recoverTc (returnTc (wanted `consBag` givens, emptyLIE, emptyBag, emptyLIE))
 398                   (simplify_one simplify_always givens wanted)
 399                                 `thenTc` \ (givens1, frees1, binds1, irreds1) ->
 400         eTC givens1 wanteds     `thenTc` \ (givens2, frees2, binds2, irreds2) ->
 401         returnTc (givens2, frees1 `plusLIE` frees2,
 402                            binds1 `unionBags` binds2,
 403                            irreds1 `plusLIE` irreds2)
 404
 405
 406     simplify_one simplify_always givens wanted
 407      | not (instBindingRequired wanted)
 408      =          -- No binding required for this chap, so squash right away
 409            lookupInst wanted            `thenTc` \ (simpler_wanteds, _) ->
 410            eTC givens simpler_wanteds   `thenTc` \ (givens1, frees1, binds1, irreds1) ->
 411            returnTc (wanted `consBag` givens1, frees1, binds1, irreds1)
 412
 413      | otherwise
 414      =          -- An binding is required for this inst
 415         lookupInst wanted               `thenTc` \ (simpler_wanteds, bind@(_,rhs)) ->
 416
 417         if (not_var rhs && not simplify_always) then
 418            -- Ho ho!  It isn't trivial to simplify "wanted",
 419            -- because the rhs isn't a simple variable.  Unless the flag
 420            -- simplify_always is set, just give up now and
 421            -- just fling it out the top.
 422            returnTc (wanted `consLIE` givens, unitLIE wanted, emptyBag, emptyLIE)
 423         else
 424            -- Aha! Either it's easy, or simplify_always is True
 425            -- so we must do it right here.
 426            eTC givens simpler_wanteds   `thenTc` \ (givens1, frees1, binds1, irreds1) ->
 427            returnTc (wanted `consLIE` givens1, frees1,
 428                      binds1 `snocBag` bind,
 429                      irreds1)
 430
 431     not_var :: TcExpr s -> Bool
 432     not_var (HsVar _) = False
 433     not_var other     = True
 434 \end{code}
 435
 436
 437 %************************************************************************
 438 %*                                                                      *
 439 \subsection[elimSCs]{@elimSCs@}
 440 %*                                                                      *
 441 %************************************************************************
 442
 443 \begin{code}
 444 elimSCs :: LIE s                                -- Given; no dups
 445         -> LIE s                                -- Wanted; no dups; all dictionaries, all
 446                                                 -- constraining just a type variable
 447         -> NF_TcM s (Bag (TcIdOcc s,TcExpr s),  -- Bindings
 448                      LIE s)                     -- Minimal wanted set
 449
 450 elimSCs givens wanteds
 451   = -- Sort the wanteds so that subclasses occur before superclasses
 452     elimSCs_help
 453         (filterBag isDict givens)       -- Filter out non-dictionaries
 454         (sortSC wanteds)
 455
 456 elimSCs_help :: LIE s                                   -- Given; no dups
 457              -> [Inst s]                                -- Wanted; no dups;
 458              -> NF_TcM s (Bag (TcIdOcc s, TcExpr s),    -- Bindings
 459                           LIE s)                        -- Minimal wanted set
 460
 461 elimSCs_help given [] = returnNF_Tc (emptyBag, emptyLIE)
 462
 463 elimSCs_help givens (wanted:wanteds)
 464   = trySC givens wanted                 `thenNF_Tc` \ (givens1, binds1, irreds1) ->
 465     elimSCs_help givens1 wanteds        `thenNF_Tc` \ (binds2, irreds2) ->
 466     returnNF_Tc (binds1 `unionBags` binds2, irreds1 `plusLIE` irreds2)
 467
 468
 469 trySC :: LIE s                          -- Givens
 470       -> Inst s                         -- Wanted
 471       -> NF_TcM s (LIE s,                       -- New givens,
 472                    Bag (TcIdOcc s,TcExpr s),    -- Bindings
 473                    LIE s)                       -- Irreducible wanted set
 474
 475 trySC givens wanted@(Dict _ wanted_class wanted_ty wanted_orig loc)
 476   | not (maybeToBool maybe_best_subclass_chain)
 477   =     -- No superclass relationship
 478     returnNF_Tc (givens, emptyBag, unitLIE wanted)
 479
 480   | otherwise
 481   =     -- There's a subclass relationship with a "given"
 482         -- Build intermediate dictionaries
 483     let
 484         theta = [ (clas, wanted_ty) | clas <- reverse classes ]
 485         -- The reverse is because the list comes back in the "wrong" order I think
 486     in
 487     newDictsAtLoc wanted_orig loc theta         `thenNF_Tc` \ (intermediates, _) ->
 488
 489         -- Create bindings for the wanted dictionary and the intermediates.
 490         -- Later binds may depend on earlier ones, so each new binding is pushed
 491         -- on the front of the accumulating parameter list of bindings
 492     let
 493         mk_bind (dict,clas) dict_sub@(Dict _ dict_sub_class ty _ _)
 494           = ((dict_sub, dict_sub_class),
 495              (instToId dict, DictApp (TyApp (HsVar (RealId (classSuperDictSelId dict_sub_class
 496                                                                               clas)))
 497                                             [ty])
 498                                      [instToId dict_sub]))
 499         (_, new_binds) = mapAccumR mk_bind (wanted,wanted_class) (given : intermediates)
 500     in
 501     returnNF_Tc (wanted `consLIE` givens `plusLIE` listToBag intermediates,
 502                  listToBag new_binds,
 503                  emptyLIE)
 504
 505   where
 506     maybe_best_subclass_chain = foldBag choose_best find_subclass_chain Nothing givens
 507     Just (given, classes, _) = maybe_best_subclass_chain
 508
 509     choose_best c1@(Just (_,_,n1)) c2@(Just (_,_,n2)) | n1 <= n2  = c1
 510                                                       | otherwise = c2
 511     choose_best Nothing            c2                             = c2
 512     choose_best c1                 Nothing                        = c1
 513
 514     find_subclass_chain given@(Dict _ given_class given_ty _ _)
 515          | wanted_ty `eqSimpleTy` given_ty
 516          = case (wanted_class `isSuperClassOf` given_class) of
 517
 518                  Just classes -> Just (given,
 519                                        classes,
 520                                        length classes)
 521
 522                  Nothing      -> Nothing
 523
 524          | otherwise = Nothing
 525
 526
 527 sortSC :: LIE s     -- Expected to be all dicts (no MethodIds), all of
 528                     -- which constrain type variables
 529        -> [Inst s]  -- Sorted with subclasses before superclasses
 530
 531 sortSC dicts = sortLt lt (bagToList dicts)
 532   where
 533     (Dict _ c1 ty1 _ _) `lt` (Dict _ c2 ty2 _ _)
 534        = if ty1 `eqSimpleTy` ty2 then
 535                 maybeToBool (c2 `isSuperClassOf` c1)
 536          else
 537                 -- order is immaterial, I think...
 538                 False
 539 \end{code}
 540
 541
 542 %************************************************************************
 543 %*                                                                      *
 544 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
 545 %*                                                                      *
 546 %************************************************************************
 547
 548 When doing a binding group, we may have @Insts@ of local functions.
 549 For example, we might have...
 550 \begin{verbatim}
 551 let f x = x + 1     -- orig local function (overloaded)
 552     f.1 = f Int     -- two instances of f
 553     f.2 = f Float
 554  in
 555     (f.1 5, f.2 6.7)
 556 \end{verbatim}
 557 The point is: we must drop the bindings for @f.1@ and @f.2@ here,
 558 where @f@ is in scope; those @Insts@ must certainly not be passed
 559 upwards towards the top-level.  If the @Insts@ were binding-ified up
 560 there, they would have unresolvable references to @f@.
 561
 562 We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
 563 For each method @Inst@ in the @init_lie@ that mentions one of the
 564 @Ids@, we create a binding.  We return the remaining @Insts@ (in an
 565 @LIE@), as well as the @HsBinds@ generated.
 566
 567 \begin{code}
 568 bindInstsOfLocalFuns :: LIE s -> [TcIdBndr s] -> TcM s (LIE s, TcMonoBinds s)
 569
 570 bindInstsOfLocalFuns init_lie local_ids
 571   = foldrTc bind_inst (emptyBag, EmptyMonoBinds) (bagToList init_lie)
 572   where
 573     bind_inst inst@(Method uniq (TcId id) tys rho orig loc) (insts, binds)
 574       | id `is_elem` local_ids
 575       = lookupInst inst         `thenTc` \ (dict_insts, (id,rhs)) ->
 576         returnTc (listToBag dict_insts `plusLIE` insts,
 577                   VarMonoBind id rhs `AndMonoBinds` binds)
 578
 579     bind_inst some_other_inst (insts, binds)
 580         -- Either not a method, or a method instance for an id not in local_ids
 581       = returnTc (some_other_inst `consBag` insts, binds)
 582
 583     is_elem = isIn "bindInstsOfLocalFuns"
 584 \end{code}
 585
 586
 587 %************************************************************************
 588 %*                                                                      *
 589 \section[Disambig]{Disambiguation of overloading}
 590 %*                                                                      *
 591 %************************************************************************
 592
 593
 594 If a dictionary constrains a type variable which is
 595 \begin{itemize}
 596 \item
 597 not mentioned in the environment
 598 \item
 599 and not mentioned in the type of the expression
 600 \end{itemize}
 601 then it is ambiguous. No further information will arise to instantiate
 602 the type variable; nor will it be generalised and turned into an extra
 603 parameter to a function.
 604
 605 It is an error for this to occur, except that Haskell provided for
 606 certain rules to be applied in the special case of numeric types.
 607
 608 Specifically, if
 609 \begin{itemize}
 610 \item
 611 at least one of its classes is a numeric class, and
 612 \item
 613 all of its classes are numeric or standard
 614 \end{itemize}
 615 then the type variable can be defaulted to the first type in the
 616 default-type list which is an instance of all the offending classes.
 617
 618 So here is the function which does the work.  It takes the ambiguous
 619 dictionaries and either resolves them (producing bindings) or
 620 complains.  It works by splitting the dictionary list by type
 621 variable, and using @disambigOne@ to do the real business.
 622
 623 IMPORTANT: @disambiguate@ assumes that its argument dictionaries
 624 constrain only a simple type variable.
 625
 626 \begin{code}
 627 type SimpleDictInfo s = (Inst s, Class, TcTyVar s)
 628
 629 disambiguateDicts :: LIE s -> TcM s ()
 630
 631 disambiguateDicts insts
 632   = mapTc disambigOne inst_infos    `thenTc` \ binds_lists ->
 633     returnTc ()
 634   where
 635     inst_infos = equivClasses cmp_tyvars (map mk_inst_info (bagToList insts))
 636     (_,_,tv1) `cmp_tyvars` (_,_,tv2) = tv1 `cmp` tv2
 637
 638     mk_inst_info dict@(Dict _ clas ty _ _)
 639       = (dict, clas, getTyVar "disambiguateDicts" ty)
 640 \end{code}
 641
 642 @disambigOne@ assumes that its arguments dictionaries constrain all
 643 the same type variable.
 644
 645 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
 646 @()@ instead of @Int@.  I reckon this is the Right Thing to do since
 647 the most common use of defaulting is code like:
 648 \begin{verbatim}
 649         _ccall_ foo     `seqPrimIO` bar
 650 \end{verbatim}
 651 Since we're not using the result of @foo@, the result if (presumably)
 652 @void@.
 653 WDP Comment: no such thing as voidTy; so not quite in yet (94/07).
 654 SLPJ comment: since
 655
 656 \begin{code}
 657 disambigOne :: [SimpleDictInfo s] -> TcM s ()
 658
 659 disambigOne dict_infos
 660   | not (isStandardNumericDefaultable classes)
 661   = failTc (ambigErr dicts) -- no default
 662
 663   | otherwise -- isStandardNumericDefaultable dict_infos
 664   =     -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
 665         -- SO, TRY DEFAULT TYPES IN ORDER
 666
 667         -- Failure here is caused by there being no type in the
 668         -- default list which can satisfy all the ambiguous classes.
 669         -- For example, if Real a is reqd, but the only type in the
 670         -- default list is Int.
 671     tcGetDefaultTys                     `thenNF_Tc` \ default_tys ->
 672     let
 673       try_default []    -- No defaults work, so fail
 674         = failTc (defaultErr dicts default_tys)
 675
 676       try_default (default_ty : default_tys)
 677         = tryTc (try_default default_tys) $     -- If default_ty fails, we try
 678                                                 -- default_tys instead
 679           tcSimplifyCheckThetas DefaultDeclOrigin thetas        `thenTc` \ _ ->
 680           returnTc default_ty
 681         where
 682           thetas = classes `zip` repeat default_ty
 683     in
 684         -- See if any default works, and if so bind the type variable to it
 685     try_default default_tys             `thenTc` \ chosen_default_ty ->
 686     tcInstType [] chosen_default_ty     `thenNF_Tc` \ chosen_default_tc_ty ->   -- Tiresome!
 687     unifyTauTy (mkTyVarTy tyvar) chosen_default_tc_ty
 688
 689   where
 690     (_,_,tyvar) = head dict_infos               -- Should be non-empty
 691     dicts   = [dict | (dict,_,_) <- dict_infos]
 692     classes = [clas | (_,clas,_) <- dict_infos]
 693
 694 \end{code}
 695
 696 @isStandardNumericDefaultable@ sees whether the dicts have the
 697 property required for defaulting; namely at least one is numeric, and
 698 all are standard; or all are CcallIsh.
 699
 700 \begin{code}
 701 isStandardNumericDefaultable :: [Class] -> Bool
 702
 703 isStandardNumericDefaultable classes
 704   = --pprTrace "isStdNumeric:\n" (ppAboves [ppCat (map (ppr PprDebug) classes), ppCat (map (ppr PprDebug . isNumericClass) classes), ppCat (map (ppr PprDebug . isStandardClass) classes), ppCat (map (ppr PprDebug . isCcallishClass) classes)]) $
 705      (any isNumericClass classes && all isStandardClass classes)
 706   || (all isCcallishClass classes)
 707 \end{code}
 708
 709
 710
 711 Errors and contexts
 712 ~~~~~~~~~~~~~~~~~~~
 713 ToDo: for these error messages, should we note the location as coming
 714 from the insts, or just whatever seems to be around in the monad just
 715 now?
 716
 717 \begin{code}
 718 genCantGenErr insts sty -- Can't generalise these Insts
 719   = ppHang (ppStr "Cannot generalise these overloadings (in a _ccall_):")
 720            4  (ppAboves (map (ppr sty) (bagToList insts)))
 721 \end{code}
 722
 723 \begin{code}
 724 ambigErr insts sty
 725   = ppHang (ppStr "Ambiguous overloading")
 726         4 (ppAboves (map (ppr sty) insts))
 727 \end{code}
 728
 729 @reduceErr@ complains if we can't express required dictionaries in
 730 terms of the signature.
 731
 732 \begin{code}
 733 reduceErr insts sty
 734   = ppHang (ppStr "Type signature lacks context required by inferred type")
 735          4 (ppHang (ppStr "Context reqd: ")
 736                  4 (ppAboves (map (ppr sty) (bagToList insts)))
 737           )
 738 \end{code}
 739
 740 \begin{code}
 741 defaultErr dicts defaulting_tys sty
 742   = ppHang (ppStr "Ambiguously-overloaded types could not be resolved:")
 743          4 (ppAboves [
 744              ppHang (ppStr "Conflicting:")
 745                   4 (ppInterleave ppSemi (map (ppr sty) dicts)),
 746              ppHang (ppStr "Defaulting types :")
 747                   4 (ppr sty defaulting_tys),
 748              ppStr "([Int, Double] is the default list of defaulting types.)" ])
 749 \end{code}
 750