[project @ 1997-05-18 22:26:40 by sof]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcSimplify.lhs
index 7962527..c1d9ec6 100644 (file)
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[TcSimplify]{TcSimplify}
 
@@ -7,44 +7,56 @@
 #include "HsVersions.h"
 
 module TcSimplify (
-       tcSimplify, tcSimplifyAndCheck, tcSimplifyWithExtraGlobals,
+       tcSimplify, tcSimplifyAndCheck,
        tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, tcSimplifyRank2,
        bindInstsOfLocalFuns
     ) where
 
-import Ubiq
+IMP_Ubiq()
 
 import HsSyn           ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit, 
-                         Match, HsBinds, Qual, PolyType, ArithSeqInfo,
-                         GRHSsAndBinds, Stmt, Fake )
-import TcHsSyn         ( TcIdOcc(..), TcIdBndr(..), TcExpr(..), TcMonoBinds(..) )
+                         Match, HsBinds, HsType, ArithSeqInfo, Fixity,
+                         GRHSsAndBinds, Stmt, DoOrListComp, Fake )
+import HsBinds         ( andMonoBinds )
+import TcHsSyn         ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr), 
+                         SYN_IE(TcMonoBinds), SYN_IE(TcDictBinds) )
 
 import TcMonad
-import Inst            ( lookupInst, tyVarsOfInst, isTyVarDict, isDict, matchesInst,
-                         instToId, instBindingRequired, instCanBeGeneralised, newDictsAtLoc,
-                         Inst(..), LIE(..), zonkLIE, emptyLIE, plusLIE, unitLIE, consLIE,
-                         InstOrigin(..), OverloadedLit )
+import Inst            ( lookupInst, lookupSimpleInst,
+                         tyVarsOfInst, isTyVarDict, isDict,
+                         matchesInst, instToId, instBindingRequired,
+                         instCanBeGeneralised, newDictsAtLoc,
+                         pprInst,
+                         Inst(..), SYN_IE(LIE), zonkLIE, emptyLIE,
+                         plusLIE, unitLIE, consLIE, InstOrigin(..),
+                         OverloadedLit )
 import TcEnv           ( tcGetGlobalTyVars )
-import TcType          ( TcType(..), TcTyVar(..), TcTyVarSet(..), TcMaybe, tcInstType )
+import SpecEnv         ( SpecEnv )
+import TcType          ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), TcMaybe, tcInstType )
 import Unify           ( unifyTauTy )
 
 import Bag             ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList, 
                          snocBag, consBag, unionBags, isEmptyBag )
-import Class           ( isNumericClass, isStandardClass, isCcallishClass,
-                         isSuperClassOf, getSuperDictSelId )
+import Class           ( GenClass, SYN_IE(Class), SYN_IE(ClassInstEnv),
+                         isSuperClassOf, classSuperDictSelId, classInstEnv
+                       )
 import Id              ( GenId )
-import Maybes          ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool, Maybe(..) )
-import Outputable      ( Outputable(..) )
+import PrelInfo                ( isNumericClass, isStandardClass, isCcallishClass )
+
+import Maybes          ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool )
+import Outputable      ( Outputable(..){-instance * []-} )
+import PprStyle
 import PprType         ( GenType, GenTyVar )
 import Pretty
-import SrcLoc          ( mkUnknownSrcLoc )
-import Util
-import Type            ( GenType, Type(..), TauType(..), mkTyVarTy, getTyVar, eqSimpleTy )
-import TysWiredIn      ( intTy )
-import TyVar           ( GenTyVar, GenTyVarSet(..), 
+import SrcLoc          ( noSrcLoc )
+import Type            ( GenType, SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, getTyVar, eqSimpleTy,
+                         getTyVar_maybe )
+import TysWiredIn      ( intTy, unitTy )
+import TyVar           ( GenTyVar, SYN_IE(GenTyVarSet), 
                          elementOfTyVarSet, emptyTyVarSet, unionTyVarSets,
                          isEmptyTyVarSet, tyVarSetToList )
 import Unique          ( Unique )
+import Util
 \end{code}
 
 
@@ -78,7 +90,7 @@ tcSimpl :: Bool                               -- True <=> simplify const insts
        -> LIE s                        -- Given; these constrain only local tyvars
        -> LIE s                        -- Wanted
        -> TcM s (LIE s,                        -- Free
-                 [(TcIdOcc s,TcExpr s)],       -- Bindings
+                 TcMonoBinds s,                -- Bindings
                  LIE s)                        -- Remaining wanteds; no dups
 
 tcSimpl squash_consts global_tvs local_tvs givens wanteds
@@ -128,7 +140,7 @@ tcSimpl squash_consts global_tvs local_tvs givens wanteds
     elimSCs givens locals              `thenNF_Tc` \ (sc_binds, locals2) ->
 
         -- Finished
-    returnTc (globals, bagToList (sc_binds `unionBags` tycon_binds), locals2)
+    returnTc (globals, sc_binds `AndMonoBinds` tycon_binds, locals2)
   where
     is_ambiguous (Dict _ _ ty _ _)
        = not (getTyVar "is_ambiguous" ty `elementOfTyVarSet` local_tvs)
@@ -146,7 +158,7 @@ tcSimplify
        :: TcTyVarSet s                 -- ``Local''  type variables
        -> LIE s                        -- Wanted
        -> TcM s (LIE s,                        -- Free
-                 [(TcIdOcc s,TcExpr s)],       -- Bindings
+                 TcDictBinds s,                -- Bindings
                  LIE s)                        -- Remaining wanteds; no dups
 
 tcSimplify local_tvs wanteds
@@ -154,26 +166,6 @@ tcSimplify local_tvs wanteds
     tcSimpl False global_tvs local_tvs emptyBag wanteds
 \end{code}
 
-@tcSimplifyWithExtraGlobals@ is just like @tcSimplify@ except that you get
-to specify some extra global type variables that the simplifer will treat
-as free in the environment.
-
-\begin{code}
-tcSimplifyWithExtraGlobals
-       :: TcTyVarSet s                 -- Extra ``Global'' type variables
-       -> TcTyVarSet s                 -- ``Local''  type variables
-       -> LIE s                        -- Wanted
-       -> TcM s (LIE s,                        -- Free
-                 [(TcIdOcc s,TcExpr s)],       -- Bindings
-                 LIE s)                        -- Remaining wanteds; no dups
-
-tcSimplifyWithExtraGlobals extra_global_tvs local_tvs wanteds
-  = tcGetGlobalTyVars                  `thenNF_Tc` \ global_tvs ->
-    tcSimpl False
-           (global_tvs `unionTyVarSets` extra_global_tvs)
-           local_tvs emptyBag wanteds
-\end{code}
-
 @tcSimplifyAndCheck@ is similar to the above, except that it checks
 that there is an empty wanted-set at the end.  It may still return
 some of constant insts, which have to be resolved finally at the end.
@@ -183,8 +175,8 @@ tcSimplifyAndCheck
         :: TcTyVarSet s                -- ``Local''  type variables; ASSERT is fixpoint
         -> LIE s                       -- Given
         -> LIE s                       -- Wanted
-        -> TcM s (LIE s,                       -- Free
-                  [(TcIdOcc s,TcExpr s)])      -- Bindings
+        -> TcM s (LIE s,               -- Free
+                  TcDictBinds s)       -- Bindings
 
 tcSimplifyAndCheck local_tvs givens wanteds
   = tcGetGlobalTyVars                  `thenNF_Tc` \ global_tvs ->
@@ -202,7 +194,7 @@ is not overloaded.
 tcSimplifyRank2 :: TcTyVarSet s                -- ``Local'' type variables; ASSERT is fixpoint
                -> LIE s                -- Given
                -> TcM s (LIE s,                        -- Free
-                         [(TcIdOcc s,TcExpr s)])       -- Bindings
+                         TcDictBinds s)        -- Bindings
 
 
 tcSimplifyRank2 local_tvs givens
@@ -217,80 +209,19 @@ tcSimplifyRank2 local_tvs givens
 
     checkTc (isEmptyBag wanteds) (reduceErr wanteds)   `thenTc_`
 
-    returnTc (free, bagToList dict_binds)
+    returnTc (free, dict_binds)
 \end{code}
 
 @tcSimplifyTop@ deals with constant @Insts@, using the standard simplification
 mechansim with the extra flag to say ``beat out constant insts''.
 
 \begin{code}
-tcSimplifyTop :: LIE s -> TcM s [(TcIdOcc s, TcExpr s)]
+tcSimplifyTop :: LIE s -> TcM s (TcDictBinds s)
 tcSimplifyTop dicts
-  = tcGetGlobalTyVars                                          `thenNF_Tc` \ global_tvs ->
-    tcSimpl True emptyTyVarSet emptyTyVarSet emptyBag dicts    `thenTc` \ (_, binds, _) ->
+  = tcSimpl True emptyTyVarSet emptyTyVarSet emptyBag dicts    `thenTc` \ (_, binds, _) ->
     returnTc binds
 \end{code}
 
-@tcSimplifyThetas@ simplifies class-type constraints formed by
-@deriving@ declarations and when specialising instances.  We are
-only interested in the simplified bunch of class/type constraints.
-
-\begin{code}
-tcSimplifyThetas :: (Class -> TauType -> InstOrigin s)  -- Creates an origin for the dummy dicts
-                -> [(Class, TauType)]                -- Simplify this
-                -> TcM s [(Class, TauType)]          -- Result
-
-tcSimplifyThetas = panic "tcSimplifyThetas"
-
-{-     LATER
-tcSimplifyThetas mk_inst_origin theta
-  = let
-       dicts = listToBag (map mk_dummy_dict theta)
-    in
-        -- Do the business (this is just the heart of "tcSimpl")
-    elimTyCons True (\tv -> False) emptyLIE dicts    `thenTc`  \ (_, _, dicts2) ->
-
-         -- Deal with superclass relationships
-    elimSCs [] dicts2              `thenNF_Tc` \ (_, dicts3) ->
-
-    returnTc (map unmk_dummy_dict (bagToList dicts3))
-  where
-    mk_dummy_dict (clas, ty) = Dict uniq clas ty (mk_inst_origin clas ty) mkUnknownSrcLoc
-    uniq                    = panic "tcSimplifyThetas:uniq"
-
-    unmk_dummy_dict (Dict _ clas ty _ _) = (clas, ty)
--}
-\end{code}
-
-@tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
-used with \tr{default} declarations.  We are only interested in
-whether it worked or not.
-
-\begin{code}
-tcSimplifyCheckThetas :: InstOrigin s          -- context; for error msg
-                     -> [(Class, TauType)]     -- Simplify this
-                     -> TcM s ()
-
-tcSimplifyCheckThetas = panic "tcSimplifyCheckThetas"
-
-{-     LATER
-tcSimplifyCheckThetas origin theta
-  = let
-       dicts = map mk_dummy_dict theta
-    in
-        -- Do the business (this is just the heart of "tcSimpl")
-    elimTyCons True (\tv -> False) emptyLIE dicts    `thenTc`  \ _ ->
-
-    returnTc ()
-  where
-    mk_dummy_dict (clas, ty)
-      = Dict uniq clas ty origin mkUnknownSrcLoc
-
-    uniq = panic "tcSimplifyCheckThetas:uniq"
--}
-\end{code}
-
-
 %************************************************************************
 %*                                                                     *
 \subsection[elimTyCons]{@elimTyCons@}
@@ -303,7 +234,7 @@ elimTyCons :: Bool                          -- True <=> Simplify const insts
           -> LIE s                             -- Given
           -> LIE s                             -- Wanted
           -> TcM s (LIE s,                     -- Free
-                    Bag (TcIdOcc s, TcExpr s), -- Bindings
+                    TcDictBinds s,             -- Bindings
                     LIE s                      -- Remaining wanteds; no dups;
                                                -- dicts only (no Methods)
               )
@@ -337,9 +268,9 @@ elimTyCons squash_consts is_free_tv givens wanteds
     returnTc (free,binds,irreds)
   where
 --    eTC :: LIE s -> [Inst s]
---       -> TcM s (LIE s, LIE s, Bag (TcIdOcc s, TcExpr s), LIE s)
+--       -> TcM s (LIE s, LIE s, TcDictBinds s, LIE s)
 
-    eTC givens [] = returnTc (givens, emptyBag, emptyBag, emptyBag)
+    eTC givens [] = returnTc (givens, emptyBag, EmptyMonoBinds, emptyBag)
 
     eTC givens (wanted:wanteds)
     -- Case 0: same as an existing inst
@@ -348,8 +279,8 @@ elimTyCons squash_consts is_free_tv givens wanteds
        let
          -- Create a new binding iff it's needed
          this = expectJust "eTC" maybe_equiv
-         new_binds | instBindingRequired wanted = (instToId wanted, HsVar (instToId this))
-                                                  `consBag` binds
+         new_binds | instBindingRequired wanted = (VarMonoBind (instToId wanted) (HsVar (instToId this)))
+                                                  `AndMonoBinds` binds
                    | otherwise                  = binds
        in
        returnTc (givens1, frees, new_binds, irreds)
@@ -391,12 +322,12 @@ elimTyCons squash_consts is_free_tv givens wanteds
 
     simplify_it simplify_always givens wanted wanteds
        -- Recover immediately on no-such-instance errors
-      = recoverTc (returnTc (wanted `consBag` givens, emptyLIE, emptyBag, emptyLIE)) 
+      = recoverTc (returnTc (wanted `consBag` givens, emptyLIE, EmptyMonoBinds, emptyLIE)) 
                  (simplify_one simplify_always givens wanted)
                                `thenTc` \ (givens1, frees1, binds1, irreds1) ->
        eTC givens1 wanteds     `thenTc` \ (givens2, frees2, binds2, irreds2) ->
        returnTc (givens2, frees1 `plusLIE` frees2,
-                          binds1 `unionBags` binds2,
+                          binds1 `AndMonoBinds` binds2,
                           irreds1 `plusLIE` irreds2)
 
 
@@ -409,20 +340,20 @@ elimTyCons squash_consts is_free_tv givens wanteds
 
      | otherwise
      =                 -- An binding is required for this inst
-       lookupInst wanted               `thenTc` \ (simpler_wanteds, bind@(_,rhs)) ->
+       lookupInst wanted               `thenTc` \ (simpler_wanteds, bind@(VarMonoBind _ rhs)) ->
 
        if (not_var rhs && not simplify_always) then
           -- Ho ho!  It isn't trivial to simplify "wanted",
           -- because the rhs isn't a simple variable.  Unless the flag
           -- simplify_always is set, just give up now and
           -- just fling it out the top.
-          returnTc (wanted `consLIE` givens, unitLIE wanted, emptyBag, emptyLIE)
+          returnTc (wanted `consLIE` givens, unitLIE wanted, EmptyMonoBinds, emptyLIE)
        else
           -- Aha! Either it's easy, or simplify_always is True
           -- so we must do it right here.
           eTC givens simpler_wanteds   `thenTc` \ (givens1, frees1, binds1, irreds1) ->
           returnTc (wanted `consLIE` givens1, frees1,
-                    binds1 `snocBag` bind,
+                    binds1 `AndMonoBinds` bind,
                     irreds1)
 
     not_var :: TcExpr s -> Bool
@@ -441,7 +372,7 @@ elimTyCons squash_consts is_free_tv givens wanteds
 elimSCs :: LIE s                               -- Given; no dups
        -> LIE s                                -- Wanted; no dups; all dictionaries, all
                                                -- constraining just a type variable
-       -> NF_TcM s (Bag (TcIdOcc s,TcExpr s),  -- Bindings
+       -> NF_TcM s (TcDictBinds s,             -- Bindings
                     LIE s)                     -- Minimal wanted set
 
 elimSCs givens wanteds
@@ -452,27 +383,27 @@ elimSCs givens wanteds
 
 elimSCs_help :: LIE s                                  -- Given; no dups
             -> [Inst s]                                -- Wanted; no dups;
-            -> NF_TcM s (Bag (TcIdOcc s, TcExpr s),    -- Bindings
+            -> NF_TcM s (TcDictBinds s,                -- Bindings
                          LIE s)                        -- Minimal wanted set
 
-elimSCs_help given [] = returnNF_Tc (emptyBag, emptyLIE)
+elimSCs_help given [] = returnNF_Tc (EmptyMonoBinds, emptyLIE)
 
 elimSCs_help givens (wanted:wanteds)
   = trySC givens wanted                `thenNF_Tc` \ (givens1, binds1, irreds1) ->
     elimSCs_help givens1 wanteds       `thenNF_Tc` \ (binds2, irreds2) ->
-    returnNF_Tc (binds1 `unionBags` binds2, irreds1 `plusLIE` irreds2)
+    returnNF_Tc (binds1 `AndMonoBinds` binds2, irreds1 `plusLIE` irreds2)
 
 
 trySC :: LIE s                         -- Givens
       -> Inst s                                -- Wanted
       -> NF_TcM s (LIE s,                      -- New givens,
-                  Bag (TcIdOcc s,TcExpr s),    -- Bindings
+                  TcDictBinds s,               -- Bindings
                   LIE s)                       -- Irreducible wanted set
 
 trySC givens wanted@(Dict _ wanted_class wanted_ty wanted_orig loc)
   | not (maybeToBool maybe_best_subclass_chain)
   =    -- No superclass relationship
-    returnNF_Tc (givens, emptyBag, unitLIE wanted)
+    returnNF_Tc ((wanted `consLIE` givens), EmptyMonoBinds, unitLIE wanted)
 
   | otherwise
   =    -- There's a subclass relationship with a "given"
@@ -489,14 +420,15 @@ trySC givens wanted@(Dict _ wanted_class wanted_ty wanted_orig loc)
     let
        mk_bind (dict,clas) dict_sub@(Dict _ dict_sub_class ty _ _)
          = ((dict_sub, dict_sub_class),
-            (instToId dict, DictApp (TyApp (HsVar (RealId (getSuperDictSelId dict_sub_class 
+            (VarMonoBind (instToId dict)
+                         (DictApp (TyApp (HsVar (RealId (classSuperDictSelId dict_sub_class 
                                                                              clas)))
                                            [ty])
-                                    [instToId dict_sub]))
+                                    [instToId dict_sub])))
        (_, new_binds) = mapAccumR mk_bind (wanted,wanted_class) (given : intermediates)
     in
     returnNF_Tc (wanted `consLIE` givens `plusLIE` listToBag intermediates,
-                listToBag new_binds,
+                andMonoBinds new_binds,
                 emptyLIE)
 
   where
@@ -528,16 +460,94 @@ sortSC :: LIE s     -- Expected to be all dicts (no MethodIds), all of
 sortSC dicts = sortLt lt (bagToList dicts)
   where
     (Dict _ c1 ty1 _ _) `lt` (Dict _ c2 ty2 _ _)
-       = if ty1 `eqSimpleTy` ty2 then
-               maybeToBool (c2 `isSuperClassOf` c1)
-        else
-               -- order is immaterial, I think...
-               False
+       = maybeToBool (c2 `isSuperClassOf` c1)
+       -- The ice is a bit thin here because this "lt" isn't a total order
+       -- But it *is* transitive, so it works ok
 \end{code}
 
 
 %************************************************************************
 %*                                                                     *
+\subsection[simple]{@Simple@ versions}
+%*                                                                     *
+%************************************************************************
+
+Much simpler versions when there are no bindings to make!
+
+@tcSimplifyThetas@ simplifies class-type constraints formed by
+@deriving@ declarations and when specialising instances.  We are
+only interested in the simplified bunch of class/type constraints.
+
+\begin{code}
+tcSimplifyThetas :: (Class -> ClassInstEnv)            -- How to find the ClassInstEnv
+                -> [(Class, TauType)]                  -- Given
+                -> [(Class, TauType)]                  -- Wanted
+                -> TcM s [(Class, TauType)]
+
+
+tcSimplifyThetas inst_mapper given wanted
+  = elimTyConsSimple inst_mapper wanted        `thenTc`    \ wanted1 ->
+    returnTc (elimSCsSimple given wanted1)
+\end{code}
+
+@tcSimplifyCheckThetas@ just checks class-type constraints, essentially;
+used with \tr{default} declarations.  We are only interested in
+whether it worked or not.
+
+\begin{code}
+tcSimplifyCheckThetas :: [(Class, TauType)]    -- Simplify this to nothing at all
+                     -> TcM s ()
+
+tcSimplifyCheckThetas theta
+  = elimTyConsSimple classInstEnv theta    `thenTc`    \ theta1 ->
+    ASSERT( null theta1 )
+    returnTc ()
+\end{code}
+
+
+\begin{code}
+elimTyConsSimple :: (Class -> ClassInstEnv) 
+                -> [(Class,Type)]
+                -> TcM s [(Class,Type)]
+elimTyConsSimple inst_mapper theta
+  = elim theta
+  where
+    elim []              = returnTc []
+    elim ((clas,ty):rest) = elim_one clas ty   `thenTc` \ r1 ->
+                           elim rest           `thenTc` \ r2 ->
+                           returnTc (r1++r2)
+
+    elim_one clas ty
+       = case getTyVar_maybe ty of
+
+           Just tv   -> returnTc [(clas,ty)]
+
+           otherwise -> recoverTc (returnTc []) $
+                        lookupSimpleInst (inst_mapper clas) clas ty    `thenTc` \ theta ->
+                        elim theta
+
+elimSCsSimple :: [(Class,Type)]        -- Given
+             -> [(Class,Type)]         -- Wanted
+             -> [(Class,Type)]         -- Subset of wanted; no dups, no subclass relnships
+
+elimSCsSimple givens [] = []
+elimSCsSimple givens (c_t@(clas,ty) : rest)
+  | any (`subsumes` c_t) givens ||
+    any (`subsumes` c_t) rest                          -- (clas,ty) is old hat
+  = elimSCsSimple givens rest
+  | otherwise                                          -- (clas,ty) is new
+  = c_t : elimSCsSimple (c_t : givens) rest
+  where
+    rest' = elimSCsSimple rest
+    (c1,t1) `subsumes` (c2,t2) = t1 `eqSimpleTy` t2 && 
+                                (c1 == c2 || maybeToBool (c2 `isSuperClassOf` c1))
+-- We deal with duplicates here   ^^^^^^^^
+-- It's a simple place to do it, although it's done in elimTyCons in the
+-- full-blown version of the simpifier.
+\end{code}
+
+%************************************************************************
+%*                                                                     *
 \subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
 %*                                                                     *
 %************************************************************************
@@ -569,9 +579,9 @@ bindInstsOfLocalFuns init_lie local_ids
   where
     bind_inst inst@(Method uniq (TcId id) tys rho orig loc) (insts, binds)
       | id `is_elem` local_ids
-      = lookupInst inst                `thenTc` \ (dict_insts, (id,rhs)) ->
+      = lookupInst inst                `thenTc` \ (dict_insts, bind) ->
        returnTc (listToBag dict_insts `plusLIE` insts, 
-                 VarMonoBind id rhs `AndMonoBinds` binds)
+                 bind `AndMonoBinds` binds)
 
     bind_inst some_other_inst (insts, binds)
        -- Either not a method, or a method instance for an id not in local_ids
@@ -647,17 +657,12 @@ the most common use of defaulting is code like:
 \end{verbatim}
 Since we're not using the result of @foo@, the result if (presumably)
 @void@.
-WDP Comment: no such thing as voidTy; so not quite in yet (94/07).
-SLPJ comment: since 
 
 \begin{code}
 disambigOne :: [SimpleDictInfo s] -> TcM s ()
 
 disambigOne dict_infos
-  | not (isStandardNumericDefaultable classes)
-  = failTc (ambigErr dicts) -- no default
-
-  | otherwise -- isStandardNumericDefaultable dict_infos
+  |  any isNumericClass classes && all isStandardClass classes
   =    -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
        -- SO, TRY DEFAULT TYPES IN ORDER
 
@@ -668,12 +673,12 @@ disambigOne dict_infos
     tcGetDefaultTys                    `thenNF_Tc` \ default_tys ->
     let
       try_default []   -- No defaults work, so fail
-       = failTc (defaultErr dicts default_tys) 
+       = failTc (ambigErr dicts) 
 
       try_default (default_ty : default_tys)
        = tryTc (try_default default_tys) $     -- If default_ty fails, we try
                                                -- default_tys instead
-         tcSimplifyCheckThetas DefaultDeclOrigin thetas        `thenTc` \ _ ->
+         tcSimplifyCheckThetas thetas  `thenTc` \ _ ->
          returnTc default_ty
         where
          thetas = classes `zip` repeat default_ty
@@ -681,7 +686,15 @@ disambigOne dict_infos
        -- See if any default works, and if so bind the type variable to it
     try_default default_tys            `thenTc` \ chosen_default_ty ->
     tcInstType [] chosen_default_ty    `thenNF_Tc` \ chosen_default_tc_ty ->   -- Tiresome!
-    unifyTauTy (mkTyVarTy tyvar) chosen_default_tc_ty
+    unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar)
+
+  | all isCcallishClass classes
+  =    -- Default CCall stuff to (); we don't even both to check that () is an 
+       -- instance of CCallable/CReturnable, because we know it is.
+    unifyTauTy (mkTyVarTy tyvar) unitTy    
+    
+  | otherwise -- No defaults
+  = failTc (ambigErr dicts)
 
   where
     (_,_,tyvar) = head dict_infos              -- Should be non-empty
@@ -690,25 +703,6 @@ disambigOne dict_infos
 
 \end{code}
 
-@isStandardNumericDefaultable@ sees whether the dicts have the
-property required for defaulting; namely at least one is numeric, and
-all are standard; or all are CcallIsh.
-
-\begin{code}
-isStandardNumericDefaultable :: [Class] -> Bool
-
-isStandardNumericDefaultable classes
-  | any isNumericClass classes && all isStandardClass classes
-  = True
-
-isStandardNumericDefaultable classes
-  | all isCcallishClass classes
-  = True
-
-isStandardNumericDefaultable classes
-  = False
-\end{code}
-
 
 
 Errors and contexts
@@ -719,14 +713,13 @@ now?
 
 \begin{code}
 genCantGenErr insts sty        -- Can't generalise these Insts
-  = ppHang (ppStr "Cannot generalise these overloadings (in a _ccall_):") 
-          4  (ppAboves (map (ppr sty) (bagToList insts)))
+  = hang (ptext SLIT("Cannot generalise these overloadings (in a _ccall_):")) 
+          4  (vcat (map (ppr sty) (bagToList insts)))
 \end{code}
 
 \begin{code}
 ambigErr insts sty
-  = ppHang (ppStr "Ambiguous overloading")
-       4 (ppAboves (map (ppr sty) insts))
+  = vcat (map (pprInst sty "Ambiguous overloading") insts)
 \end{code}
 
 @reduceErr@ complains if we can't express required dictionaries in
@@ -734,20 +727,8 @@ terms of the signature.
 
 \begin{code}
 reduceErr insts sty
-  = ppHang (ppStr "Type signature lacks context required by inferred type")
-        4 (ppHang (ppStr "Context reqd: ")
-                4 (ppAboves (map (ppr sty) (bagToList insts)))
-          )
+  = vcat (map (pprInst sty "Context required by inferred type, but missing on a type signature")
+                 (bagToList insts))
 \end{code}
 
-\begin{code}
-defaultErr dicts defaulting_tys sty
-  = ppHang (ppStr "Ambiguously-overloaded types could not be resolved:")
-        4 (ppAboves [
-            ppHang (ppStr "Conflicting:")
-                 4 (ppInterleave ppSemi (map (ppr sty) dicts)),
-            ppHang (ppStr "Defaulting types :")
-                 4 (ppr sty defaulting_tys),
-            ppStr "([Int, Double] is the default list of defaulting types.)" ])
-\end{code}