--- 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 _ _)
- = inst_mapper clas
-get_inst_env clas other_orig = classInstEnv clas
-
-
-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 (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!")
+tcSyntaxName :: InstOrigin
+ -> TcType -- Type to instantiate it at
+ -> Name -> Name -- (Standard name, user name)
+ -> TcM (TcExpr, TcType) -- Suitable expression with its type
+
+-- NB: tcSyntaxName calls tcExpr, and hence can do unification.
+-- So we do not call it from lookupInst, which is called from tcSimplify
+
+tcSyntaxName orig ty std_nm user_nm
+ | std_nm == user_nm
+ = newMethodFromName orig ty std_nm `thenM` \ id ->
+ returnM (HsVar id, idType id)
+
+ | otherwise
+ = tcLookupId std_nm `thenM` \ std_id ->
+ let
+ -- C.f. newMethodAtLoc
+ ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
+ tau1 = substTy (mkTopTyVarSubst [tv] [ty]) tau
+ in
+ addErrCtxtM (syntaxNameCtxt user_nm orig tau1) $
+ tcExpr (HsVar user_nm) tau1 `thenM` \ user_fn ->
+ returnM (user_fn, tau1)
+
+syntaxNameCtxt name orig ty tidy_env
+ = getInstLoc orig `thenM` \ inst_loc ->
+ let
+ msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+>
+ ptext SLIT("(needed by a syntactic construct)"),
+ nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
+ nest 2 (pprInstLoc inst_loc)]
+ in
+ returnM (tidy_env, msg)