--- During deriving and instance specialisation operations
--- we can't get the instances of the class from inside the
--- class, because the latter ain't ready yet. Instead we
--- find a mapping from classes to envts inside the dict origin.
-
-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)
-get_inst_env clas other_orig = classInstEnv clas
-
-
-pprOrigin :: String -> InstOrigin s -> SrcLoc -> Error
-
-pprOrigin hdr orig locn
- = addErrLoc locn hdr $ \ sty ->
- case orig of
- OccurrenceOf id ->
- ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"),
- ppr sty id, ppChar '\'']
- OccurrenceOfCon id ->
- ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"),
- ppr sty id, ppChar '\'']
- InstanceDeclOrigin ->
- ppStr "in an instance declaration"
- LiteralOrigin lit ->
- ppCat [ppStr "at an overloaded literal:", ppr sty lit]
- ArithSeqOrigin seq ->
- ppCat [ppStr "at an arithmetic sequence:", ppr sty seq]
- SignatureOrigin ->
- ppStr "in a type signature"
- DoOrigin ->
- ppStr "in a do statement"
- ClassDeclOrigin ->
- ppStr "in a class declaration"
- InstanceSpecOrigin _ clas ty ->
- ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"",
- ppr sty clas, ppStr "\" type: ", ppr sty ty]
- ValSpecOrigin name ->
- ppBesides [ppStr "in a SPECIALIZE user-pragma for `",
- ppr sty name, ppStr "'"]
- CCallOrigin clabel Nothing{-ccall result-} ->
- ppBesides [ppStr "in the result of the _ccall_ to `",
- ppStr clabel, ppStr "'"]
- CCallOrigin clabel (Just arg_expr) ->
- ppBesides [ppStr "in an argument in the _ccall_ to `",
- ppStr clabel, ppStr "', namely: ", ppr sty arg_expr]
- LitLitOrigin s ->
- ppBesides [ppStr "in this ``literal-literal'': ", ppStr s]
- UnknownOrigin ->
- ppStr "in... oops -- I don't know where the overloading came from!"
+pprOrigin :: Inst s -> SDoc
+pprOrigin inst
+ = hsep [text "arising from", pp_orig orig, text "at", ppr 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"), quotes (ppr id)]
+ pp_orig (OccurrenceOfCon id)
+ = hsep [ptext SLIT("use of"), quotes (ppr id)]
+ pp_orig (LiteralOrigin lit)
+ = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
+ pp_orig (InstanceDeclOrigin)
+ = ptext SLIT("an instance declaration")
+ pp_orig (ArithSeqOrigin seq)
+ = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr 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",
+ quotes (ppr clas), text "type:", ppr ty]
+ pp_orig (ValSpecOrigin name)
+ = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
+ pp_orig (CCallOrigin clabel Nothing{-ccall result-})
+ = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
+ pp_orig (CCallOrigin clabel (Just arg_expr))
+ = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
+ text "namely", quotes (ppr arg_expr)]
+ pp_orig (LitLitOrigin s)
+ = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
+ pp_orig (UnknownOrigin)
+ = ptext SLIT("...oops -- I don't know where the overloading came from!")