--- 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 :: 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!"
+lookupSimpleInst :: Class
+ -> [Type] -- Look up (c,t)
+ -> NF_TcM (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s
+
+lookupSimpleInst clas tys
+ = tcGetInstEnv `thenNF_Tc` \ inst_env ->
+ case lookupInstEnv inst_env clas tys of
+ FoundInst tenv dfun
+ -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
+ where
+ (_, theta, _) = splitSigmaTy (idType dfun)
+ theta' = map (\(Class clas tys) -> (clas,tys)) theta
+
+ other -> returnNF_Tc Nothing