From c0fde8606a2afc5a7f1e53103eed2d1fdf93999a Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Tue, 27 Jan 1998 18:39:21 +0000
Subject: [PATCH] [project @ 1998-01-27 18:39:01 by sof] Better failure message
when entering an unimplemented instance method
---
ghc/compiler/basicTypes/Unique.lhs | 102 +++++++++++++-------------
ghc/compiler/prelude/PrelInfo.lhs | 3 +-
ghc/compiler/prelude/PrelVals.lhs | 6 +-
ghc/compiler/typecheck/TcInstDcls.lhs | 21 +++---
ghc/lib/ghc/GHCerr.lhs | 12 +--
5 files changed, 70 insertions(+), 74 deletions(-)
diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index e6abf145baf3..c6b6f0a11b3a 100644
--- a/ghc/compiler/basicTypes/Unique.lhs
+++ b/ghc/compiler/basicTypes/Unique.lhs
@@ -117,9 +117,8 @@ module Unique (
mutableArrayPrimTyConKey,
mutableByteArrayPrimTyConKey,
nilDataConKey,
- noDefaultMethodErrorIdKey,
+ noMethodBindingErrorIdKey,
nonExhaustiveGuardsErrorIdKey,
- nonExplicitMethodErrorIdKey,
notIdKey,
numClassKey,
ordClassKey,
@@ -646,63 +645,62 @@ integerPlusTwoIdKey = mkPreludeMiscIdUnique 14
integerZeroIdKey = mkPreludeMiscIdUnique 15
irrefutPatErrorIdKey = mkPreludeMiscIdUnique 16
lexIdKey = mkPreludeMiscIdUnique 17
-noDefaultMethodErrorIdKey = mkPreludeMiscIdUnique 20
+noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 20
nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 21
-nonExplicitMethodErrorIdKey = mkPreludeMiscIdUnique 22
-notIdKey = mkPreludeMiscIdUnique 23
-packCStringIdKey = mkPreludeMiscIdUnique 24
-parErrorIdKey = mkPreludeMiscIdUnique 25
-parIdKey = mkPreludeMiscIdUnique 26
-patErrorIdKey = mkPreludeMiscIdUnique 27
-readParenIdKey = mkPreludeMiscIdUnique 28
-realWorldPrimIdKey = mkPreludeMiscIdUnique 29
-recConErrorIdKey = mkPreludeMiscIdUnique 30
-recUpdErrorIdKey = mkPreludeMiscIdUnique 31
-seqIdKey = mkPreludeMiscIdUnique 33
-showParenIdKey = mkPreludeMiscIdUnique 34
-showSpaceIdKey = mkPreludeMiscIdUnique 35
-showStringIdKey = mkPreludeMiscIdUnique 36
-traceIdKey = mkPreludeMiscIdUnique 37
-unpackCString2IdKey = mkPreludeMiscIdUnique 38
-unpackCStringAppendIdKey = mkPreludeMiscIdUnique 39
-unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 40
-unpackCStringIdKey = mkPreludeMiscIdUnique 41
-voidIdKey = mkPreludeMiscIdUnique 42
-ushowListIdKey = mkPreludeMiscIdUnique 43
-ureadListIdKey = mkPreludeMiscIdUnique 44
-
-copyableIdKey = mkPreludeMiscIdUnique 45
-noFollowIdKey = mkPreludeMiscIdUnique 46
-parAtAbsIdKey = mkPreludeMiscIdUnique 47
-parAtForNowIdKey = mkPreludeMiscIdUnique 48
-parAtIdKey = mkPreludeMiscIdUnique 49
-parAtRelIdKey = mkPreludeMiscIdUnique 50
-parGlobalIdKey = mkPreludeMiscIdUnique 51
-parLocalIdKey = mkPreludeMiscIdUnique 52
+notIdKey = mkPreludeMiscIdUnique 22
+packCStringIdKey = mkPreludeMiscIdUnique 23
+parErrorIdKey = mkPreludeMiscIdUnique 24
+parIdKey = mkPreludeMiscIdUnique 25
+patErrorIdKey = mkPreludeMiscIdUnique 26
+readParenIdKey = mkPreludeMiscIdUnique 27
+realWorldPrimIdKey = mkPreludeMiscIdUnique 28
+recConErrorIdKey = mkPreludeMiscIdUnique 29
+recUpdErrorIdKey = mkPreludeMiscIdUnique 30
+seqIdKey = mkPreludeMiscIdUnique 31
+showParenIdKey = mkPreludeMiscIdUnique 32
+showSpaceIdKey = mkPreludeMiscIdUnique 33
+showStringIdKey = mkPreludeMiscIdUnique 34
+traceIdKey = mkPreludeMiscIdUnique 35
+unpackCString2IdKey = mkPreludeMiscIdUnique 36
+unpackCStringAppendIdKey = mkPreludeMiscIdUnique 37
+unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 38
+unpackCStringIdKey = mkPreludeMiscIdUnique 39
+voidIdKey = mkPreludeMiscIdUnique 40
+ushowListIdKey = mkPreludeMiscIdUnique 41
+ureadListIdKey = mkPreludeMiscIdUnique 42
+
+copyableIdKey = mkPreludeMiscIdUnique 43
+noFollowIdKey = mkPreludeMiscIdUnique 44
+parAtAbsIdKey = mkPreludeMiscIdUnique 45
+parAtForNowIdKey = mkPreludeMiscIdUnique 46
+parAtIdKey = mkPreludeMiscIdUnique 47
+parAtRelIdKey = mkPreludeMiscIdUnique 48
+parGlobalIdKey = mkPreludeMiscIdUnique 49
+parLocalIdKey = mkPreludeMiscIdUnique 50
\end{code}
Certain class operations from Prelude classes. They get
their own uniques so we can look them up easily when we want
to conjure them up during type checking.
\begin{code}
-fromIntClassOpKey = mkPreludeMiscIdUnique 53
-fromIntegerClassOpKey = mkPreludeMiscIdUnique 54
-minusClassOpKey = mkPreludeMiscIdUnique 55
-fromRationalClassOpKey = mkPreludeMiscIdUnique 56
-enumFromClassOpKey = mkPreludeMiscIdUnique 57
-enumFromThenClassOpKey = mkPreludeMiscIdUnique 58
-enumFromToClassOpKey = mkPreludeMiscIdUnique 59
-enumFromThenToClassOpKey= mkPreludeMiscIdUnique 60
-eqClassOpKey = mkPreludeMiscIdUnique 61
-geClassOpKey = mkPreludeMiscIdUnique 62
-zeroClassOpKey = mkPreludeMiscIdUnique 63
-thenMClassOpKey = mkPreludeMiscIdUnique 64 -- (>>=)
-unboundKey = mkPreludeMiscIdUnique 65 -- Just a place holder for unbound
+fromIntClassOpKey = mkPreludeMiscIdUnique 51
+fromIntegerClassOpKey = mkPreludeMiscIdUnique 52
+minusClassOpKey = mkPreludeMiscIdUnique 53
+fromRationalClassOpKey = mkPreludeMiscIdUnique 54
+enumFromClassOpKey = mkPreludeMiscIdUnique 55
+enumFromThenClassOpKey = mkPreludeMiscIdUnique 56
+enumFromToClassOpKey = mkPreludeMiscIdUnique 57
+enumFromThenToClassOpKey= mkPreludeMiscIdUnique 58
+eqClassOpKey = mkPreludeMiscIdUnique 59
+geClassOpKey = mkPreludeMiscIdUnique 60
+zeroClassOpKey = mkPreludeMiscIdUnique 61
+thenMClassOpKey = mkPreludeMiscIdUnique 62 -- (>>=)
+unboundKey = mkPreludeMiscIdUnique 63 -- Just a place holder for unbound
-- variables produced by the renamer
-fromEnumClassOpKey = mkPreludeMiscIdUnique 66
+fromEnumClassOpKey = mkPreludeMiscIdUnique 64
-mainKey = mkPreludeMiscIdUnique 67
-returnMClassOpKey = mkPreludeMiscIdUnique 68
-otherwiseIdKey = mkPreludeMiscIdUnique 69
-toEnumClassOpKey = mkPreludeMiscIdUnique 70
+mainKey = mkPreludeMiscIdUnique 65
+returnMClassOpKey = mkPreludeMiscIdUnique 66
+otherwiseIdKey = mkPreludeMiscIdUnique 67
+toEnumClassOpKey = mkPreludeMiscIdUnique 68
\end{code}
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index 1edca06f2fea..21c2ea28b3be 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -208,8 +208,7 @@ wired_in_ids
, integerPlusTwoId
, integerZeroId
, nON_EXHAUSTIVE_GUARDS_ERROR_ID
- , nO_DEFAULT_METHOD_ERROR_ID
- , nO_EXPLICIT_METHOD_ERROR_ID
+ , nO_METHOD_BINDING_ERROR_ID
, pAR_ERROR_ID
, pAT_ERROR_ID
, packStringForCId
diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs
index c3885b6b1839..513cec4c8609 100644
--- a/ghc/compiler/prelude/PrelVals.lhs
+++ b/ghc/compiler/prelude/PrelVals.lhs
@@ -95,10 +95,8 @@ iRREFUT_PAT_ERROR_ID
= generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError")
nON_EXHAUSTIVE_GUARDS_ERROR_ID
= generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError")
-nO_DEFAULT_METHOD_ERROR_ID
- = generic_ERROR_ID noDefaultMethodErrorIdKey SLIT("noDefaultMethodError")
-nO_EXPLICIT_METHOD_ERROR_ID
- = generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError")
+nO_METHOD_BINDING_ERROR_ID
+ = generic_ERROR_ID noMethodBindingErrorIdKey SLIT("noMethodBindingError")
aBSENT_ERROR_ID
= pc_bottoming_Id absentErrorIdKey gHC_ERR SLIT("absentErr")
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 97a8b157f0d3..8406ff6ebd1f 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -67,7 +67,7 @@ import Name ( nameOccName, getSrcLoc, mkLocalName,
isLocallyDefined, Module,
NamedThing(..)
)
-import PrelVals ( nO_EXPLICIT_METHOD_ERROR_ID, nO_DEFAULT_METHOD_ERROR_ID )
+import PrelVals ( nO_METHOD_BINDING_ERROR_ID )
import PprType ( pprParendGenType, pprConstraint )
import SrcLoc ( SrcLoc, noSrcLoc )
import TyCon ( tyConDataCons, isSynTyCon, isDataTyCon, tyConDerivings )
@@ -504,19 +504,20 @@ tcInstMethodBind clas inst_tys inst_tyvars meth_binds (sel_id, maybe_dm_id)
mk_default_bind local_meth_name loc
= PatMonoBind (VarPatIn local_meth_name)
- (GRHSsAndBindsIn (unguardedRHS default_expr loc) EmptyBinds)
+ (GRHSsAndBindsIn (unguardedRHS (default_expr loc) loc) EmptyBinds)
loc
- default_expr = case maybe_dm_id of
- Just dm_id -> HsVar (getName dm_id) -- There's a default method
- Nothing -> error_expr -- No default method
+ default_expr loc
+ = case maybe_dm_id of
+ Just dm_id -> HsVar (getName dm_id) -- There's a default method
+ Nothing -> error_expr loc -- No default method
- error_expr = HsApp (HsVar (getName nO_DEFAULT_METHOD_ERROR_ID))
- (HsLit (HsString (_PK_ error_msg)))
+ error_expr loc
+ = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID))
+ (HsLit (HsString (_PK_ (error_msg loc))))
+
+ error_msg loc = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
- error_msg = show (hcat [ppr (getSrcLoc sel_id), text "|",
- ppr sel_id
- ])
\end{code}
diff --git a/ghc/lib/ghc/GHCerr.lhs b/ghc/lib/ghc/GHCerr.lhs
index afa3f15ac67a..578fcacf8148 100644
--- a/ghc/lib/ghc/GHCerr.lhs
+++ b/ghc/lib/ghc/GHCerr.lhs
@@ -17,8 +17,7 @@ module GHCerr
(
irrefutPatError
- , noDefaultMethodError
- , noExplicitMethodError
+ , noMethodBindingError
, nonExhaustiveGuardsError
, patError
, recConError
@@ -124,15 +123,16 @@ seqError = error "Oops! Entered seqError (a GHC bug -- please report it!)\n"
\begin{code}
irrefutPatError
- , noDefaultMethodError
- , noExplicitMethodError
+ , noMethodBindingError
+ --, noExplicitMethodError
, nonExhaustiveGuardsError
, patError
, recConError
, recUpdError :: String -> a
-noDefaultMethodError s = error ("noDefaultMethodError:"++s)
-noExplicitMethodError s = error ("No default method for class operation "++s)
+--noDefaultMethodError s = error ("noDefaultMethodError:"++s)
+--noExplicitMethodError s = error ("No default method for class operation "++s)
+noMethodBindingError s = error (untangle s "No instance nor default method for class operation")
irrefutPatError s = error (untangle s "Irrefutable pattern failed for pattern")
nonExhaustiveGuardsError s = error (untangle s "Non-exhaustive guards in")
patError s = error (untangle s "Non-exhaustive patterns in")
--
GitLab