ghc/compiler/typecheck/Disambig.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1993-1995
   3 %
   4 %************************************************************************
   5 %*                                                                      *
   6 \section[Disambig]{Disambiguation of overloading}
   7 %*                                                                      *
   8 %************************************************************************
   9
  10 \begin{code}
  11 #include "HsVersions.h"
  12
  13 module Disambig (
  14         disambiguateDicts,
  15
  16         -- and for self-sufficiency...
  17         Inst, Subst, UniqueSupply, Bag, Error(..), SrcLoc,
  18         TcResult, Pretty(..), PprStyle, PrettyRep
  19     ) where
  20
  21 import TcMonad
  22 import AbsSyn
  23
  24 import AbsPrel          ( intTyCon, intTy, {-ToDo:?voidTy,-} doubleTyCon )
  25 import AbsUniType       ( applyTyCon, getTyVar, cmpTyVar, getClassKey,
  26                           isNumericClass, isStandardClass
  27                         )
  28 import Errors           ( ambigErr, defaultErr, Error(..), UnifyErrContext(..) )
  29 import Id               ( Id, DictVar(..) )
  30 import Inst             --( Inst(..), InstOrigin(..), OverloadedLit  )
  31 import InstEnv          ( lookupClassInstAtSimpleType )
  32 import Maybes           ( Maybe(..), firstJust )
  33 import SrcLoc           ( mkUnknownSrcLoc )
  34 import TcSimplify       ( tcSimplifyCheckThetas )
  35 import Unique           ( cReturnableClassKey )
  36 import Util
  37 \end{code}
  38
  39 If a dictionary constrains a type variable which is
  40 \begin{itemize}
  41 \item
  42 not mentioned in the environment
  43 \item
  44 and not mentioned in the type of the expression
  45 \end{itemize}
  46 then it is ambiguous. No further information will arise to instantiate
  47 the type variable; nor will it be generalised and turned into an extra
  48 parameter to a function.
  49
  50 It is an error for this to occur, except that Haskell provided for
  51 certain rules to be applied in the special case of numeric types.
  52
  53 Specifically, if
  54 \begin{itemize}
  55 \item
  56 at least one of its classes is a numeric class, and
  57 \item
  58 all of its classes are numeric or standard
  59 \end{itemize}
  60 then the type variable can be defaulted to the first type in the
  61 default-type list which is an instance of all the offending classes.
  62
  63 So here is the function which does the work.  It takes the ambiguous
  64 dictionaries and either resolves them (producing bindings) or
  65 complains.  It works by splitting the dictionary list by type
  66 variable, and using @disambigOne@ to do the real business.
  67
  68 IMPORTANT: @disambiguate@ assumes that its argument dictionaries
  69 constrain only a simple type variable.
  70
  71 \begin{code}
  72 type SimpleDictInfo = (Inst, Class, TyVar)
  73
  74 disambiguateDicts :: [Inst] -> TcM ()
  75
  76 disambiguateDicts insts
  77   = mapTc disambigOne inst_infos    `thenTc` \ binds_lists ->
  78     returnTc ()
  79   where
  80     inst_infos = equivClasses cmp_tyvars (map mk_inst_info insts)
  81     (_,_,tv1) `cmp_tyvars` (_,_,tv2) = tv1 `cmpTyVar` tv2
  82
  83     mk_inst_info dict@(Dict _ clas ty _)
  84       = (dict, clas, getTyVar "disambiguateDicts" ty)
  85 \end{code}
  86
  87 @disambigOne@ assumes that its arguments dictionaries constrain all
  88 the same type variable.
  89
  90 ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
  91 @()@ instead of @Int@.  I reckon this is the Right Thing to do since
  92 the most common use of defaulting is code like:
  93 \begin{verbatim}
  94         _ccall_ foo     `seqPrimIO` bar
  95 \end{verbatim}
  96 Since we're not using the result of @foo@, the result if (presumably)
  97 @void@.
  98 WDP Comment: no such thing as voidTy; so not quite in yet (94/07).
  99
 100 \begin{code}
 101 disambigOne :: [SimpleDictInfo] -> TcM ()
 102
 103 disambigOne dict_infos
 104   | isCReturnable dict_infos
 105         -- C-returnable; just default to Void
 106   =  extendSubstTc tyvar intTy{-ToDo:voidTy-} (AmbigDictCtxt dicts)
 107
 108   | not (isStandardNumericDefaultable dict_infos)
 109   = failTc (ambigErr dicts) -- no default
 110
 111   | otherwise -- isStandardNumericDefaultable dict_infos
 112   =     -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
 113         -- SO, TRY DEFAULT TYPES IN ORDER
 114
 115         -- Failure here is caused by there being no type in the
 116         -- default list which can satisfy all the ambiguous classes.
 117         -- For example, if Real a is reqd, but the only type in the
 118         -- default list is Int.
 119     getDefaultingTys                `thenNF_Tc` \ default_tys ->
 120
 121     mapNF_Tc try_default default_tys `thenNF_Tc` \ maybe_tys ->
 122
 123     checkMaybeTc (firstJust maybe_tys)
 124                  (defaultErr dicts default_tys)
 125                                     `thenTc` \ chosen_default_ty ->
 126
 127         -- SUCCESS; COMBINE TO A BINDS, AND EXTEND SUBSTITUTION
 128     extendSubstTc tyvar chosen_default_ty (AmbigDictCtxt dicts)
 129
 130   where
 131     (_,_,tyvar) = head dict_infos               -- Should be non-empty
 132     dicts = [dict | (dict,_,_) <- dict_infos]
 133
 134     try_default :: UniType -> NF_TcM (Maybe UniType)
 135
 136     try_default default_ty
 137       = let
 138             thetas = [(clas, default_ty) | (_,clas,_) <- dict_infos]
 139         in
 140         recoverQuietlyTc Nothing ( -- if tcSimplify hates us, we get the Nothing
 141
 142             tcSimplifyCheckThetas (DefaultDeclOrigin mkUnknownSrcLoc) thetas `thenTc` \ _ ->
 143             returnTc (Just default_ty)
 144         )
 145 \end{code}
 146
 147 @isStandardNumericDefaultable@ sees whether the dicts have the
 148 property required for defaulting; namely at least one is numeric, and
 149 all are standard.
 150
 151 \begin{code}
 152 isCReturnable, isStandardNumericDefaultable :: [SimpleDictInfo] -> Bool
 153
 154 isStandardNumericDefaultable dict_infos
 155   =    (any (\ (_,c,_) -> isNumericClass c)  dict_infos)
 156     && (all (\ (_,c,_) -> isStandardClass c) dict_infos)
 157
 158 isCReturnable [(_,c,_)] = getClassKey c == cReturnableClassKey
 159 isCReturnable _         = False -- duplicates will have been removed,
 160                                 -- so we don't have to worry about
 161                                 -- multiple copies of cReturnableClassKey...
 162 \end{code}