[project @ 1997-10-14 09:37:44 by simonm]
[ghc-hetmet.git] / ghc / compiler / typecheck / Inst.lhs
index b4fc7f2..67688c0 100644 (file)
@@ -10,9 +10,10 @@ module Inst (
        Inst(..),       -- Visible only to TcSimplify
 
        InstOrigin(..), OverloadedLit(..),
-       LIE(..), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs,
+       SYN_IE(LIE), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs,
+       pprLIE, pprLIEInFull,
 
-        InstanceMapper(..),
+        SYN_IE(InstanceMapper),
 
        newDicts, newDictsAtLoc, newMethod, newMethodWithGivenTy, newOverloadedLit,
 
@@ -23,45 +24,59 @@ module Inst (
        zonkInst, instToId,
 
        matchesInst,
-       instBindingRequired, instCanBeGeneralised
-
+       instBindingRequired, instCanBeGeneralised,
+       
+       pprInst
     ) where
 
-import Ubiq
-
-import HsSyn   ( HsLit(..), HsExpr(..), HsBinds, 
-                 InPat, OutPat, Stmt, Qual, Match,
-                 ArithSeqInfo, PolyType, Fake )
-import RnHsSyn ( RenamedArithSeqInfo(..), RenamedHsExpr(..) )
-import TcHsSyn ( TcIdOcc(..), TcExpr(..), TcIdBndr(..),
-                 mkHsTyApp, mkHsDictApp )
-
-import TcMonad hiding ( rnMtoTcM )
-import TcEnv   ( tcLookupGlobalValueByKey )
-import TcType  ( TcType(..), TcRhoType(..), TcMaybe, TcTyVarSet(..),
-                 tcInstType, zonkTcType )
-
-import Bag     ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag )
-import Class   ( Class(..), GenClass, ClassInstEnv(..), classInstEnv )
-import Id      ( GenId, idType, mkInstId )
+IMP_Ubiq()
+IMPORT_1_3(Ratio(Rational))
+
+import HsSyn   ( HsLit(..), HsExpr(..), HsBinds, Fixity, MonoBinds(..),
+                 InPat, OutPat, Stmt, DoOrListComp, Match, GRHSsAndBinds,
+                 ArithSeqInfo, HsType, Fake )
+import RnHsSyn ( SYN_IE(RenamedArithSeqInfo), SYN_IE(RenamedHsExpr) )
+import TcHsSyn ( SYN_IE(TcExpr), 
+                 SYN_IE(TcDictBinds), SYN_IE(TcMonoBinds),
+                 mkHsTyApp, mkHsDictApp, tcIdTyVars )
+
+import TcMonad
+import TcEnv   ( tcLookupGlobalValueByKey, tcLookupTyConByKey )
+import TcType  ( TcIdOcc(..), SYN_IE(TcIdBndr), 
+                 SYN_IE(TcType), SYN_IE(TcRhoType), TcMaybe, SYN_IE(TcTyVarSet),
+                 tcInstType, zonkTcType, tcSplitForAllTy, tcSplitRhoTy )
+
+import Bag     ( emptyBag, unitBag, unionBags, unionManyBags, bagToList,
+                 listToBag, consBag, Bag )
+import Class   ( classInstEnv,
+                 SYN_IE(Class), GenClass, SYN_IE(ClassInstEnv) 
+               )
+import ErrUtils ( addErrLoc, SYN_IE(Error) )
+import Id      ( GenId, idType, mkInstId, SYN_IE(Id) )
+import PrelInfo        ( isCcallishClass, isNoDictClass )
 import MatchEnv        ( lookupMEnv, insertMEnv )
-import Name    ( mkLocalName, getLocalName, Name )
+import Name    ( OccName(..), Name, mkLocalName, 
+                 mkSysLocalName, occNameString, getOccName )
 import Outputable
-import PprType ( GenClass, TyCon, GenType, GenTyVar )  
-import PprStyle        ( PprStyle(..) )
+import PprType ( GenClass, TyCon, GenType, GenTyVar, pprParendGenType )        
 import Pretty
-import RnHsSyn ( RnName{-instance NamedThing-} )
-import SpecEnv ( SpecEnv(..) )
-import SrcLoc  ( SrcLoc, mkUnknownSrcLoc )
+import SpecEnv ( SpecEnv )
+import SrcLoc  ( SrcLoc, noSrcLoc )
 import Type    ( GenType, eqSimpleTy, instantiateTy,
                  isTyVarTy, mkDictTy, splitForAllTy, splitSigmaTy,
-                 splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes )
-import TyVar   ( GenTyVar )
+                 splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes,
+                 mkSynTy, SYN_IE(Type)
+               )
+import TyVar   ( unionTyVarSets, GenTyVar )
 import TysPrim   ( intPrimTy )
-import TysWiredIn ( intDataCon )
-import Unique  ( Unique, showUnique,
-                 fromRationalClassOpKey, fromIntClassOpKey, fromIntegerClassOpKey )
-import Util    ( panic, zipEqual, zipWithEqual, assoc, assertPanic )
+import TysWiredIn ( intDataCon, integerTy, isIntTy, isIntegerTy, inIntRange )
+import Unique  ( fromRationalClassOpKey, rationalTyConKey,
+                 fromIntClassOpKey, fromIntegerClassOpKey, Unique
+               )
+import Util    ( panic, zipEqual, zipWithEqual, assoc, assertPanic, pprTrace{-ToDo:rm-} )
+#if __GLASGOW_HASKELL__ >= 202
+import Maybes
+#endif
 \end{code}
 
 %************************************************************************
@@ -81,6 +96,16 @@ plusLIEs lies          = unionManyBags lies
 
 zonkLIE :: LIE s -> NF_TcM s (LIE s)
 zonkLIE lie = mapBagNF_Tc zonkInst lie
+
+pprLIE :: PprStyle -> LIE s -> Doc
+pprLIE sty lie = pprQuote sty $ \ sty ->
+                braces (hsep (punctuate comma (map (pprInst sty) (bagToList lie))))
+
+
+pprLIEInFull sty insts
+  = vcat (map go (bagToList insts))
+  where
+    go inst = ppr sty inst <+> pprOrigin sty inst
 \end{code}
 
 %************************************************************************
@@ -154,21 +179,30 @@ newDicts :: InstOrigin s
         -> NF_TcM s (LIE s, [TcIdOcc s])
 newDicts orig theta
   = tcGetSrcLoc                                `thenNF_Tc` \ loc ->
+    newDictsAtLoc orig loc theta        `thenNF_Tc` \ (dicts, ids) ->
+    returnNF_Tc (listToBag dicts, ids)
+{-
     tcGetUniques (length theta)                `thenNF_Tc` \ new_uniqs ->
     let
        mk_dict u (clas, ty) = Dict u clas ty orig loc
        dicts = zipWithEqual "newDicts" mk_dict new_uniqs theta
     in
     returnNF_Tc (listToBag dicts, map instToId dicts)
-
-newDictsAtLoc orig loc theta   -- Local function, similar to newDicts, 
-                               -- but with slightly different interface
-  = tcGetUniques (length theta)                `thenNF_Tc` \ new_uniqs ->
-    let
-       mk_dict u (clas, ty) = Dict u clas ty orig loc
-       dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
-    in
-    returnNF_Tc (dicts, map instToId dicts)
+-}
+
+-- Local function, similar to newDicts, 
+-- but with slightly different interface
+newDictsAtLoc :: InstOrigin s
+              -> SrcLoc
+             -> [(Class, TcType s)]
+             -> NF_TcM s ([Inst s], [TcIdOcc s])
+newDictsAtLoc orig loc theta =
+ tcGetUniques (length theta)           `thenNF_Tc` \ new_uniqs ->
+ let
+  mk_dict u (clas, ty) = Dict u clas ty orig loc
+  dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
+ in
+ returnNF_Tc (dicts, map instToId dicts)
 
 newMethod :: InstOrigin s
          -> TcIdOcc s
@@ -178,9 +212,11 @@ newMethod orig id tys
   =    -- Get the Id type and instantiate it at the specified types
     (case id of
        RealId id -> let (tyvars, rho) = splitForAllTy (idType id)
-                   in tcInstType (zipEqual "newMethod" tyvars tys) rho
-       TcId   id -> let (tyvars, rho) = splitForAllTy (idType id)
-                   in returnNF_Tc (instantiateTy (zipEqual "newMethod(2)" tyvars tys) rho)
+                   in
+                   (if length tyvars /= length tys then pprTrace "newMethod" (ppr PprDebug (idType id)) else \x->x) $
+                   tcInstType (zip{-Equal "newMethod"-} tyvars tys) rho
+       TcId   id -> tcSplitForAllTy (idType id)        `thenNF_Tc` \ (tyvars, rho) -> 
+                   returnNF_Tc (instantiateTy (zipEqual "newMethod(2)" tyvars tys) rho)
     )                                          `thenNF_Tc` \ rho_ty ->
         -- Our friend does the rest
     newMethodWithGivenTy orig id tys rho_ty
@@ -211,14 +247,26 @@ newMethodAtLoc orig loc real_id tys       -- Local function, similar to newMethod but
 newOverloadedLit :: InstOrigin s
                 -> OverloadedLit
                 -> TcType s
-                -> NF_TcM s (LIE s, TcIdOcc s)
-newOverloadedLit orig lit ty
+                -> NF_TcM s (TcExpr s, LIE s)
+newOverloadedLit orig (OverloadedIntegral i) ty
+  | isIntTy ty && inIntRange i         -- Short cut for Int
+  = returnNF_Tc (int_lit, emptyLIE)
+
+  | isIntegerTy ty                     -- Short cut for Integer
+  = returnNF_Tc (integer_lit, emptyLIE)
+
+  where
+    intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
+    integer_lit    = HsLitOut (HsInt i) integerTy
+    int_lit        = HsApp (HsVar (RealId intDataCon)) intprim_lit
+
+newOverloadedLit orig lit ty           -- The general case
   = tcGetSrcLoc                        `thenNF_Tc` \ loc ->
     tcGetUnique                        `thenNF_Tc` \ new_uniq ->
     let
        lit_inst = LitInst new_uniq lit ty orig loc
     in
-    returnNF_Tc (unitLIE lit_inst, instToId lit_inst)
+    returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 \end{code}
 
 
@@ -227,15 +275,18 @@ instToId :: Inst s -> TcIdOcc s
 instToId (Dict u clas ty orig loc)
   = TcId (mkInstId u (mkDictTy clas ty) (mkLocalName u str loc))
   where
-    str = SLIT("d.") _APPEND_ (getLocalName clas)
+    str = VarOcc (SLIT("d.") _APPEND_ (occNameString (getOccName clas)))
+
 instToId (Method u id tys rho_ty orig loc)
-  = TcId (mkInstId u tau_ty (mkLocalName u str loc))
+  = TcId (mkInstId u tau_ty (mkLocalName u occ loc))
   where
-    (_, tau_ty) = splitRhoTy rho_ty    -- NB The method Id has just the tau type
-    str = SLIT("m.") _APPEND_ (getLocalName id)
-
+    occ = getOccName id
+    (_, tau_ty) = splitRhoTy rho_ty    
+               -- I hope we don't need tcSplitRhoTy...
+               -- NB The method Id has just the tau type
+    
 instToId (LitInst u list ty orig loc)
-  = TcId (mkInstId u ty (mkLocalName u SLIT("lit") loc))
+  = TcId (mkInstId u ty (mkSysLocalName u SLIT("lit") loc))
 \end{code}
 
 \begin{code}
@@ -272,7 +323,9 @@ zonkInst (LitInst u lit ty orig loc)
 \begin{code}
 tyVarsOfInst :: Inst s -> TcTyVarSet s
 tyVarsOfInst (Dict _ _ ty _ _)        = tyVarsOfType  ty
-tyVarsOfInst (Method _ _ tys rho _ _) = tyVarsOfTypes tys
+tyVarsOfInst (Method _ id tys rho _ _) = tyVarsOfTypes tys `unionTyVarSets` tcIdTyVars id
+                                        -- The id might not be a RealId; in the case of
+                                        -- locally-overloaded class methods, for example
 tyVarsOfInst (LitInst _ _ ty _ _)     = tyVarsOfType  ty
 \end{code}
 
@@ -320,19 +373,12 @@ must be witnessed by an actual binding; the second tells whether an
 
 \begin{code}
 instBindingRequired :: Inst s -> Bool
-instBindingRequired inst
-  = case getInstOrigin inst of
-       CCallOrigin _ _   -> False      -- No binding required
-       LitLitOrigin  _   -> False
-       OccurrenceOfCon _ -> False
-       other             -> True
+instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas)
+instBindingRequired other              = True
 
 instCanBeGeneralised :: Inst s -> Bool
-instCanBeGeneralised inst
-  = case getInstOrigin inst of
-       CCallOrigin _ _ -> False        -- Can't be generalised
-       LitLitOrigin  _ -> False        -- Can't be generalised
-       other           -> True
+instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas)
+instCanBeGeneralised other              = True
 \end{code}
 
 
@@ -343,38 +389,36 @@ relevant in error messages.
 
 \begin{code}
 instance Outputable (Inst s) where
-    ppr sty (LitInst uniq lit ty orig loc)
-      = ppSep [case lit of
-                         OverloadedIntegral   i -> ppInteger i
-                         OverloadedFractional f -> ppRational f,
-              ppStr "at",
-              ppr sty ty,
-              show_uniq sty uniq
-       ]
-
-    ppr sty (Dict uniq clas ty orig loc)
-      = ppSep [ppr sty clas, 
-              ppStr "at",
-              ppr sty ty,
-              show_uniq sty uniq
-       ]
-
-    ppr sty (Method uniq id tys rho orig loc)
-      = ppSep [ppr sty id, 
-              ppStr "at",
-              ppr sty tys,
-              show_uniq sty uniq
-       ]
-
-show_uniq PprDebug uniq = ppr PprDebug uniq
-show_uniq sty     uniq = ppNil
-
+    ppr sty inst = pprQuote sty (\ sty -> pprInst sty inst)
+
+pprInst sty (LitInst u lit ty orig loc)
+  = hsep [case lit of
+             OverloadedIntegral   i -> integer i
+             OverloadedFractional f -> rational f,
+          ptext SLIT("at"),
+          ppr sty ty,
+          show_uniq sty u]
+
+pprInst sty (Dict u clas ty orig loc)
+  = hsep [ppr sty clas, pprParendGenType sty ty, show_uniq sty u]
+
+pprInst sty (Method u id tys rho orig loc)
+  = hsep [ppr sty id, ptext SLIT("at"), 
+         interppSP sty tys,
+         show_uniq sty u]
+
+show_uniq PprDebug u = ppr PprDebug u
+show_uniq sty     u = empty
 \end{code}
 
-Printing in error messages
+Printing in error messages.  These two must look the same.
 
 \begin{code}
-noInstanceErr inst sty = ppHang (ppPStr SLIT("No instance for:")) 4 (ppr sty inst)
+noInstanceErr inst sty = ptext SLIT("No instance for:") <+> ppr sty inst
+
+noSimpleInst clas ty sty
+  = ptext SLIT("No instance for:") <+> 
+    (pprQuote sty (\ sty -> ppr sty clas <+> pprParendGenType sty ty))
 \end{code}
 
 %************************************************************************
@@ -384,7 +428,7 @@ noInstanceErr inst sty = ppHang (ppPStr SLIT("No instance for:")) 4 (ppr sty ins
 %************************************************************************
 
 \begin{code}
-type InstanceMapper = Class -> (ClassInstEnv, ClassOp -> SpecEnv)
+type InstanceMapper = Class -> ClassInstEnv
 \end{code}
 
 A @ClassInstEnv@ lives inside a class, and identifies all the instances
@@ -405,14 +449,14 @@ the dfun type.
 \begin{code}
 lookupInst :: Inst s 
           -> TcM s ([Inst s], 
-                    (TcIdOcc s, TcExpr s))     -- The new binding
+                    TcDictBinds s)     -- The new binding
 
 -- Dictionaries
 
 lookupInst dict@(Dict _ clas ty orig loc)
   = case lookupMEnv matchTy (get_inst_env clas orig) ty of
       Nothing  -> tcAddSrcLoc loc               $
-                  tcAddErrCtxt (pprOrigin orig) $
+                  tcAddErrCtxt (\sty -> pprOrigin sty dict) $
                   failTc (noInstanceErr dict)
 
       Just (dfun_id, tenv) 
@@ -429,39 +473,52 @@ lookupInst dict@(Dict _ clas ty orig loc)
           let 
                rhs = mkHsDictApp (mkHsTyApp (HsVar (RealId dfun_id)) ty_args) dict_ids
           in
-          returnTc (dicts, (instToId dict, rhs))
+          returnTc (dicts, VarMonoBind (instToId dict) rhs)
                             
 
 -- Methods
 
 lookupInst inst@(Method _ id tys rho orig loc)
-  = newDictsAtLoc orig loc theta       `thenNF_Tc` \ (dicts, dict_ids) ->
-    returnTc (dicts, (instToId inst, mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
-  where
-    (theta,_) = splitRhoTy rho
+  = tcSplitRhoTy rho                   `thenNF_Tc` \ (theta, _) ->
+    newDictsAtLoc orig loc theta       `thenNF_Tc` \ (dicts, dict_ids) ->
+    returnTc (dicts, VarMonoBind (instToId inst) (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
 
 -- Literals
 
 lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
-  | i >= toInteger minInt && i <= toInteger maxInt
-  =    -- It's overloaded but small enough to fit into an Int
-    tcLookupGlobalValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int ->
-    newMethodAtLoc orig loc from_int [ty]              `thenNF_Tc` \ (method_inst, method_id) ->
-    returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) int_lit))
-
-  | otherwise 
-  =     -- Alas, it is overloaded and a big literal!
-    tcLookupGlobalValueByKey fromIntegerClassOpKey     `thenNF_Tc` \ from_integer ->
+  | isIntTy ty && in_int_range                 -- Short cut for Int
+  = returnTc ([], VarMonoBind inst_id int_lit)
+
+  | isIntegerTy ty                             -- Short cut for Integer
+  = returnTc ([], VarMonoBind inst_id integer_lit)
+
+  | in_int_range                               -- It's overloaded but small enough to fit into an Int
+  = tcLookupGlobalValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int ->
+    newMethodAtLoc orig loc from_int [ty]      `thenNF_Tc` \ (method_inst, method_id) ->
+    returnTc ([method_inst], VarMonoBind inst_id (HsApp (HsVar method_id) int_lit))
+
+  | otherwise                                  -- Alas, it is overloaded and a big literal!
+  = tcLookupGlobalValueByKey fromIntegerClassOpKey     `thenNF_Tc` \ from_integer ->
     newMethodAtLoc orig loc from_integer [ty]          `thenNF_Tc` \ (method_inst, method_id) ->
-    returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsInt i) ty)))
+    returnTc ([method_inst], VarMonoBind inst_id (HsApp (HsVar method_id) integer_lit))
   where
+    in_int_range   = inIntRange i
     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
+    integer_lit    = HsLitOut (HsInt i) integerTy
     int_lit        = HsApp (HsVar (RealId intDataCon)) intprim_lit
+    inst_id       = instToId inst
 
 lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
   = tcLookupGlobalValueByKey fromRationalClassOpKey    `thenNF_Tc` \ from_rational ->
+
+       -- The type Rational isn't wired in so we have to conjure it up
+    tcLookupTyConByKey rationalTyConKey        `thenNF_Tc` \ rational_tycon ->
+    let
+       rational_ty  = mkSynTy rational_tycon []
+       rational_lit = HsLitOut (HsFrac f) rational_ty
+    in
     newMethodAtLoc orig loc from_rational [ty]         `thenNF_Tc` \ (method_inst, method_id) ->
-    returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsFrac f) ty)))
+    returnTc ([method_inst], VarMonoBind (instToId inst) (HsApp (HsVar method_id) rational_lit))
 \end{code}
 
 There is a second, simpler interface, when you want an instance of a
@@ -481,10 +538,6 @@ lookupSimpleInst class_inst_env clas ty
       Just (dfun,tenv) -> returnTc [(c,instantiateTy tenv t) | (c,t) <- theta]
                       where
                          (_, theta, _) = splitSigmaTy (idType dfun)
-
-noSimpleInst clas ty sty
-  = ppSep [ppStr "No instance for class", ppQuote (ppr sty clas),
-          ppStr "at type", ppQuote (ppr sty ty)]
 \end{code}
 
 
@@ -555,6 +608,8 @@ data InstOrigin s
   | ArithSeqOrigin     RenamedArithSeqInfo -- [x..], [x..y] etc
 
   | SignatureOrigin            -- A dict created from a type signature
+  | Rank2Origin                        -- A dict created when typechecking the argument
+                               -- of a rank-2 typed function
 
   | DoOrigin                   -- The monad for a do expression
 
@@ -607,55 +662,48 @@ get_inst_env :: Class -> InstOrigin s -> ClassInstEnv
 -- get_inst_env clas (DerivingOrigin inst_mapper _ _)
 --  = fst (inst_mapper clas)
 get_inst_env clas (InstanceSpecOrigin inst_mapper _ _)
-  = fst (inst_mapper clas)
+  = inst_mapper clas
 get_inst_env clas other_orig = classInstEnv clas
 
 
-pprOrigin :: InstOrigin s -> PprStyle -> Pretty
-
-pprOrigin (OccurrenceOf id) sty
-      = ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"),
-                  ppr sty id, ppChar '\'']
-pprOrigin (OccurrenceOfCon id) sty
-      = ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"),
-                  ppr sty id, ppChar '\'']
-pprOrigin (InstanceDeclOrigin) sty
-      = ppStr "in an instance declaration"
-pprOrigin (LiteralOrigin lit) sty
-      = ppCat [ppStr "at an overloaded literal:", ppr sty lit]
-pprOrigin (ArithSeqOrigin seq) sty
-      = ppCat [ppStr "at an arithmetic sequence:", ppr sty seq]
-pprOrigin (SignatureOrigin) sty
-      = ppStr "in a type signature"
-pprOrigin (DoOrigin) sty
-      = ppStr "in a do statement"
-pprOrigin (ClassDeclOrigin) sty
-      = ppStr "in a class declaration"
--- pprOrigin (DerivingOrigin _ clas tycon) sty
---      = ppBesides [ppStr "in a `deriving' clause; class `",
---                       ppr sty clas,
---                       ppStr "'; offending type `",
---                       ppr sty tycon,
---                       ppStr "'"]
-pprOrigin (InstanceSpecOrigin _ clas ty) sty
-      = ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"",
-                  ppr sty clas, ppStr "\" type: ", ppr sty ty]
--- pprOrigin (DefaultDeclOrigin) sty
---      = ppStr "in a `default' declaration"
-pprOrigin (ValSpecOrigin name) sty
-      = ppBesides [ppStr "in a SPECIALIZE user-pragma for `",
-                  ppr sty name, ppStr "'"]
-pprOrigin (CCallOrigin clabel Nothing{-ccall result-}) sty
-      = ppBesides [ppStr "in the result of the _ccall_ to `",
-                  ppStr clabel, ppStr "'"]
-pprOrigin (CCallOrigin clabel (Just arg_expr)) sty
-      = ppBesides [ppStr "in an argument in the _ccall_ to `",
-                 ppStr clabel, ppStr "', namely: ", ppr sty arg_expr]
-pprOrigin (LitLitOrigin s) sty
-      = ppBesides [ppStr "in this ``literal-literal'': ", ppStr s]
-pprOrigin UnknownOrigin sty
-      = ppStr "in... oops -- I don't know where the overloading came from!"
+pprOrigin :: PprStyle -> Inst s -> Doc
+pprOrigin sty inst
+  = hsep [text "arising from", pp_orig orig, text "at", ppr sty locn]
+  where
+    (orig, locn) = case inst of
+                       Dict _ _ _     orig loc -> (orig,loc)
+                       Method _ _ _ _ orig loc -> (orig,loc)
+                       LitInst _ _ _  orig loc -> (orig,loc)
+                       
+    pp_orig (OccurrenceOf id)
+       = hsep [ptext SLIT("use of"), ppr sty id]
+    pp_orig (OccurrenceOfCon id)
+       = hsep [ptext SLIT("use of"), ppr sty id]
+    pp_orig (LiteralOrigin lit)
+       = hsep [ptext SLIT("the literal"), ppr sty lit]
+    pp_orig (InstanceDeclOrigin)
+       =  ptext SLIT("an instance declaration")
+    pp_orig (ArithSeqOrigin seq)
+       = hsep [ptext SLIT("the arithmetic sequence:"), ppr sty seq]
+    pp_orig (SignatureOrigin)
+       =  ptext SLIT("a type signature")
+    pp_orig (Rank2Origin)
+       =  ptext SLIT("a function with an overloaded argument type")
+    pp_orig (DoOrigin)
+       =  ptext SLIT("a do statement")
+    pp_orig (ClassDeclOrigin)
+       =  ptext SLIT("a class declaration")
+    pp_orig (InstanceSpecOrigin _ clas ty)
+       = hsep [text "a SPECIALIZE instance pragma; class",
+              ppr sty clas, text "type:", ppr sty ty]
+    pp_orig (ValSpecOrigin name)
+       = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), ppr sty name]
+    pp_orig (CCallOrigin clabel Nothing{-ccall result-})
+       = hsep [ptext SLIT("the result of the _ccall_ to"), text clabel]
+    pp_orig (CCallOrigin clabel (Just arg_expr))
+       = hsep [ptext SLIT("an argument in the _ccall_ to"), text clabel <> comma, text "namely", ppr sty arg_expr]
+    pp_orig (LitLitOrigin s)
+       = hsep [ptext SLIT("the ``literal-literal''"), text s]
+    pp_orig (UnknownOrigin)
+       = ptext SLIT("...oops -- I don't know where the overloading came from!")
 \end{code}
-
-
-