Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
995d6dbf
Commit
995d6dbf
authored
May 18, 1997
by
sof
Browse files
[project @ 1997-05-18 22:57:44 by sof]
new PP;2.04 update
parent
3b3e0e79
Changes
3
Expand all
Hide whitespace changes
Inline
Side-by-side
ghc/compiler/typecheck/Inst.lhs
View file @
995d6dbf
...
...
@@ -31,27 +31,30 @@ module Inst (
IMP_Ubiq()
IMPORT_1_3(Ratio(Rational))
import HsSyn ( HsLit(..), HsExpr(..), HsBinds, Fixity,
InPat, OutPat, Stmt, DoOrListComp, Match,
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 ( TcIdOcc(..), SYN_IE(TcExpr), SYN_IE(TcIdBndr),
import TcHsSyn ( TcIdOcc(..), SYN_IE(TcExpr), SYN_IE(TcIdBndr),
SYN_IE(TcDictBinds), SYN_IE(TcMonoBinds),
mkHsTyApp, mkHsDictApp, tcIdTyVars )
import TcMonad
import TcEnv ( tcLookupGlobalValueByKey, tcLookupTyConByKey )
import TcType ( SYN_IE(TcType), SYN_IE(TcRhoType), TcMaybe, SYN_IE(TcTyVarSet),
tcInstType, zonkTcType )
tcInstType, zonkTcType
, tcSplitForAllTy, tcSplitRhoTy
)
import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
listToBag, consBag, Bag )
import Class ( classInstEnv,
SYN_IE(Class), GenClass, SYN_IE(ClassInstEnv), SYN_IE(ClassOp)
)
import ErrUtils ( addErrLoc, SYN_IE(Error) )
import Id ( GenId, idType, mkInstId )
import Id ( GenId, idType, mkInstId
, SYN_IE(Id)
)
import PrelInfo ( isCcallishClass, isNoDictClass )
import MatchEnv ( lookupMEnv, insertMEnv )
import Name ( OccName(..), Name, mkLocalName, mkSysLocalName, occNameString )
import Name ( OccName(..), Name, mkLocalName,
mkSysLocalName, occNameString, getOccName )
import Outputable
import PprType ( GenClass, TyCon, GenType, GenTyVar, pprParendGenType )
import PprStyle ( PprStyle(..) )
...
...
@@ -61,7 +64,7 @@ import SrcLoc ( SrcLoc, noSrcLoc )
import Type ( GenType, eqSimpleTy, instantiateTy,
isTyVarTy, mkDictTy, splitForAllTy, splitSigmaTy,
splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes,
mkSynTy
mkSynTy
, SYN_IE(Type)
)
import TyVar ( unionTyVarSets, GenTyVar )
import TysPrim ( intPrimTy )
...
...
@@ -70,6 +73,9 @@ import Unique ( showUnique, fromRationalClassOpKey, rationalTyConKey,
fromIntClassOpKey, fromIntegerClassOpKey, Unique
)
import Util ( panic, zipEqual, zipWithEqual, assoc, assertPanic, pprTrace{-ToDo:rm-} )
#if __GLASGOW_HASKELL__ >= 202
import Maybes
#endif
\end{code}
%************************************************************************
...
...
@@ -198,8 +204,8 @@ newMethod orig id tys
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 ->
let (tyvars, rho) = s
plitForAllTy (idType id)
in
returnNF_Tc (instantiateTy (zipEqual "newMethod(2)" tyvars tys) rho)
TcId id ->
tcS
plitForAllTy (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
...
...
@@ -249,11 +255,13 @@ instToId (Dict u clas ty orig loc)
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 = VarOcc (SLIT("m.") _APPEND_ (occNameString (getOccName 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 (mkSysLocalName u SLIT("lit") loc))
\end{code}
...
...
@@ -358,35 +366,35 @@ relevant in error messages.
\begin{code}
instance Outputable (Inst s) where
ppr sty inst = ppr_inst sty
ppNil
(\ o l ->
ppNil
) inst
ppr sty inst = ppr_inst sty
empty
(\ o l ->
empty
) inst
pprInst sty hdr inst = ppr_inst sty hdr (\ o l -> pprOrigin hdr o l sty) inst
ppr_inst sty hdr ppr_orig (LitInst u lit ty orig loc)
=
ppH
ang (ppr_orig orig loc)
4 (
ppCat
[case lit of
OverloadedIntegral i ->
ppI
nteger i
OverloadedFractional f ->
ppR
ational f,
p
pPStr
SLIT("at"),
=
h
ang (ppr_orig orig loc)
4 (
hsep
[case lit of
OverloadedIntegral i ->
i
nteger i
OverloadedFractional f ->
r
ational f,
p
text
SLIT("at"),
ppr sty ty,
show_uniq sty u])
ppr_inst sty hdr ppr_orig (Dict u clas ty orig loc)
=
ppH
ang (ppr_orig orig loc)
4 (
ppCat
[ppr sty clas, pprParendGenType sty ty, show_uniq sty u])
=
h
ang (ppr_orig orig loc)
4 (
hsep
[ppr sty clas, pprParendGenType sty ty, show_uniq sty u])
ppr_inst sty hdr ppr_orig (Method u id tys rho orig loc)
=
ppH
ang (ppr_orig orig loc)
4 (
ppCat
[ppr sty id, p
pPStr
SLIT("at"), interppSP sty tys, show_uniq sty u])
=
h
ang (ppr_orig orig loc)
4 (
hsep
[ppr sty id, p
text
SLIT("at"), interppSP sty tys, show_uniq sty u])
show_uniq PprDebug u = ppr PprDebug u
show_uniq sty u =
ppNil
show_uniq sty u =
empty
\end{code}
Printing in error messages
\begin{code}
noInstanceErr inst sty =
ppH
ang (p
pPStr
SLIT("No instance for:")) 4 (ppr sty inst)
noInstanceErr inst sty =
h
ang (p
text
SLIT("No instance for:")) 4 (ppr sty inst)
\end{code}
%************************************************************************
...
...
@@ -417,7 +425,7 @@ the dfun type.
\begin{code}
lookupInst :: Inst s
-> TcM s ([Inst s],
(
Tc
IdOcc s, TcExpr
s)
)
-- The new binding
Tc
DictBinds
s) -- The new binding
-- Dictionaries
...
...
@@ -441,16 +449,15 @@ 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
...
...
@@ -459,13 +466,13 @@ lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
= -- 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))
returnTc ([method_inst],
VarMonoBind
(instToId inst
) (
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) integerTy)))
returnTc ([method_inst],
VarMonoBind
(instToId inst
) (
HsApp (HsVar method_id) (HsLitOut (HsInt i) integerTy)))
where
intprim_lit = HsLitOut (HsIntPrim i) intPrimTy
int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit
...
...
@@ -480,7 +487,7 @@ lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
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) rational_lit))
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
...
...
@@ -502,8 +509,8 @@ lookupSimpleInst class_inst_env clas ty
(_, theta, _) = splitSigmaTy (idType dfun)
noSimpleInst clas ty sty
=
ppS
ep [p
pPStr
SLIT("No instance for class"),
ppQuote (
ppr sty clas
)
,
p
pPStr
SLIT("at type"),
ppQuote (
ppr sty ty
)
]
=
s
ep [p
text
SLIT("No instance for class"), ppr sty clas,
p
text
SLIT("at type"), ppr sty ty]
\end{code}
...
...
@@ -636,37 +643,32 @@ 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 '\'']
hsep [ptext SLIT("at a use of an overloaded identifier:"), ppr sty id]
OccurrenceOfCon id ->
ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"),
ppr sty id, ppChar '\'']
hsep [ptext SLIT("at a use of an overloaded constructor:"), ppr sty id]
InstanceDeclOrigin ->
p
pPStr
SLIT("in an instance declaration")
p
text
SLIT("in an instance declaration")
LiteralOrigin lit ->
ppCat [ppPStr
SLIT("at an overloaded literal:"), ppr sty lit]
hsep [ptext
SLIT("at an overloaded literal:"), ppr sty lit]
ArithSeqOrigin seq ->
ppCat [ppPStr
SLIT("at an arithmetic sequence:"), ppr sty seq]
hsep [ptext
SLIT("at an arithmetic sequence:"), ppr sty seq]
SignatureOrigin ->
p
pPStr
SLIT("in a type signature")
p
text
SLIT("in a type signature")
DoOrigin ->
p
pPStr
SLIT("in a do statement")
p
text
SLIT("in a do statement")
ClassDeclOrigin ->
p
pPStr
SLIT("in a class declaration")
p
text
SLIT("in a class declaration")
InstanceSpecOrigin _ clas ty ->
ppBesides [ppStr
"in a SPECIALIZE instance pragma; class
\"
",
ppr sty clas,
ppStr "\"
type:
", ppr sty ty]
hsep [text
"in a SPECIALIZE instance pragma; class",
ppr sty clas,
text "
type:", ppr sty ty]
ValSpecOrigin name ->
ppBesides [ppPStr SLIT("in a SPECIALIZE user-pragma for `"),
ppr sty name, ppChar '\'']
hsep [ptext SLIT("in a SPECIALIZE user-pragma for"), ppr sty name]
CCallOrigin clabel Nothing{-ccall result-} ->
ppBesides [ppPStr SLIT("in the result of the _ccall_ to `"),
ppStr clabel, ppChar '\'']
hsep [ptext SLIT("in the result of the _ccall_ to"), text clabel]
CCallOrigin clabel (Just arg_expr) ->
ppBesides [ppPStr SLIT("in an argument in the _ccall_ to `"),
ppStr clabel, ppStr "', namely: ", ppr sty arg_expr]
hsep [ptext SLIT("in an argument in the _ccall_ to"), text clabel <> comma, text "namely:", ppr sty arg_expr]
LitLitOrigin s ->
ppBesides [ppPStr
SLIT("in this ``literal-literal'': "),
ppStr
s]
hcat [ptext
SLIT("in this ``literal-literal'': "),
text
s]
UnknownOrigin ->
p
pPStr
SLIT("in... oops -- I don't know where the overloading came from!")
p
text
SLIT("in... oops -- I don't know where the overloading came from!")
\end{code}
ghc/compiler/typecheck/TcBinds.lhs
View file @
995d6dbf
This diff is collapsed.
Click to expand it.
ghc/compiler/typecheck/TcClassDcl.lhs
View file @
995d6dbf
...
...
@@ -10,10 +10,11 @@ module TcClassDcl ( tcClassDecl1, tcClassDecls2 ) where
IMP_Ubiq()
import HsSyn ( HsDecl(..), ClassDecl(..), HsBinds(..),
Bind(..),
MonoBinds(..),
import HsSyn ( HsDecl(..), ClassDecl(..), HsBinds(..), MonoBinds(..),
Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
DefaultDecl, TyDecl, InstDecl, IfaceSig, Fixity,
HsLit(..), OutPat(..), Sig(..), HsType(..), HsTyVar,
SYN_IE(RecFlag), nonRecursive, andMonoBinds,
Stmt, DoOrListComp, ArithSeqInfo, InPat, Fake )
import HsTypes ( getTyVarName )
import HsPragmas ( ClassPragmas(..) )
...
...
@@ -27,7 +28,7 @@ import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(Tc
import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), emptyLIE, plusLIE, newDicts, newMethod )
import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcAddImportedIdInfo,
tcExtendGlobalTyVars )
import TcInstDcls (
processInst
Bind
s
)
import TcInstDcls (
tcMethod
Bind )
import TcKind ( unifyKind, TcKind )
import TcMonad
import TcMonoType ( tcHsType, tcContext )
...
...
@@ -36,25 +37,31 @@ import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars, t
import Bag ( foldBag, unionManyBags )
import Class ( GenClass, GenClassOp, mkClass, mkClassOp, classBigSig,
classOps, classOpString, classOpLocalType,
classOpTagByOccName, SYN_IE(ClassOp)
classOps, classOpString, classOpLocalType, classDefaultMethodId,
classOpTagByOccName, SYN_IE(ClassOp), SYN_IE(Class)
)
import Id ( GenId, mkSuperDictSelId, mkMethodSelId,
mkDefaultMethodId, getIdUnfolding,
idType, SYN_IE(Id)
)
import Id ( GenId, mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId, getIdUnfolding,
idType )
import CoreUnfold ( getUnfoldingTemplate )
import IdInfo
import Name ( Name, isLocallyDefined, moduleString, modAndOcc, nameString )
import Name ( Name, isLocallyDefined, moduleString,
modAndOcc, nameString, NamedThing(..) )
import Outputable
import PrelVals ( nO_DEFAULT_METHOD_ERROR_ID )
import PprStyle
import Pretty
import PprType ( GenType, GenTyVar, GenClassOp )
import PprType (
GenClass,
GenType, GenTyVar, GenClassOp )
import SpecEnv ( SpecEnv )
import SrcLoc ( mkGeneratedSrcLoc )
import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
mkForAllTy, mkSigmaTy, splitSigmaTy)
mkForAllTy, mkSigmaTy, splitSigmaTy, SYN_IE(Type)
)
import TysWiredIn ( stringTy )
import TyVar ( unitTyVarSet, GenTyVar )
import Unique ( Unique )
import TyVar ( unitTyVarSet, GenTyVar, SYN_IE(TyVar) )
import Unique ( Unique )
import UniqFM ( Uniquable(..) )
import Util
...
...
@@ -299,18 +306,22 @@ tcClassDecl2 (ClassDecl context class_name
= classBigSig clas
-- The selector binds are already in the selector Id's unfoldings
sel_binds = SingleBind $ NonRecBind $ foldr AndMonoBinds EmptyMonoBinds $
[ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
| sel_id <- sc_sel_ids ++ op_sel_ids,
isLocallyDefined sel_id
]
final_sel_binds = MonoBind (andMonoBinds sel_binds) [] nonRecursive
in
-- Generate bindings for the default methods
tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], _, _) ->
buildDefaultMethodBinds clas clas_tyvar defm_ids default_binds
`thenTc` \ (const_insts, meth_binds) ->
mapAndUnzipTc (buildDefaultMethodBind clas clas_tyvar default_binds)
(op_sel_ids `zip` [0..])
`thenTc` \ (const_insts_s, meth_binds) ->
returnTc (const_insts, sel_binds `ThenBinds` meth_binds)
returnTc (unionManyBags const_insts_s,
final_sel_binds `ThenBinds`
MonoBind (andMonoBinds meth_binds) [] nonRecursive)
\end{code}
%************************************************************************
...
...
@@ -387,151 +398,54 @@ dfun.Foo.List
\end{verbatim}
\begin{code}
buildDefaultMethodBind
s
buildDefaultMethodBind
:: Class
-> TcTyVar s
-> [Id]
-> RenamedMonoBinds
-> TcM s (LIE s, TcHsBinds s)
-> (Id, Int)
-> TcM s (LIE s, TcMonoBinds s)
buildDefaultMethodBinds clas clas_tyvar
default_method_ids default_binds
buildDefaultMethodBind clas clas_tyvar default_binds (sel_id, idx)
= newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
mapAndUnzipNF_Tc mk_method default_method_ids `thenNF_Tc` \ (insts_s, local_defm_ids) ->
let
avail_insts
= this_dict
`plusLIE` unionManyBags insts_s -- Insts available
clas_tyvar_set = unitTyVarSet clas_tyvar
avail_insts = this_dict
defm_id = classDefaultMethodId clas idx
in
tcExtendGlobalTyVars clas_tyvar_set (
processInstBinds
clas
(makeClassDeclDefaultMethodRhs clas local_defm_ids)
avail_insts
local_defm_ids
default_binds
) `thenTc` \ (insts_needed, default_binds') ->
tcSimplifyAndCheck
clas_tyvar_set
avail_insts
insts_needed `thenTc` \ (const_lie, dict_binds) ->
let
defm_binds = AbsBinds
[clas_tyvar]
[this_dict_id]
(local_defm_ids `zip` map RealId default_method_ids)
dict_binds
(RecBind default_binds')
in
returnTc (const_lie, defm_binds)
where
inst_ty = mkTyVarTy clas_tyvar
mk_method defm_id = newMethod origin (RealId defm_id) [inst_ty]
origin = ClassDeclOrigin
\end{code}
====================
buildDefaultMethodBinds
:: Class
-> TcTyVar s
-> [Id]
-> RenamedMonoBinds
-> TcM s (LIE s, TcHsBinds s)
buildDefaultMethodBinds clas clas_tyvar
default_method_ids default_binds
= newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
tcExtendGlobalTyVars clas_tyvar_set (
tcDefaultMethodBinds default_binds
)
tcDefaultMethodBinds default_meth_ids default_binds
where
go (AndMonoBinds b1 b2)
= go b1 `thenTc` \ (new_b1, lie1) ->
go b2 `thenTc` \ (new_b2, lie2) ->
returnTc (new_b1 `ThenBinds` new_b2, lie1 `plusLIE` lie2)
go EmptyMonoBinds = EmptyBinds
go mbind = processInstBinds1 clas clas_dict meth_ids mbind `thenTc` \ (tags
tcDefaultMethodBinds EmptyMonoBinds
processInstBinds
clas
(makeClassDeclDefaultMethodRhs clas local_defm_ids)
avail_insts
local_defm_ids
default_binds
) `thenTc` \ (insts_needed, default_binds') ->
let
mapAndUnzipNF_Tc mk_method default_method_ids `thenNF_Tc` \ (insts_s, local_defm_ids) ->
let
avail_insts = this_dict `plusLIE` unionManyBags insts_s -- Insts available
clas_tyvar_set = unitTyVarSet clas_tyvar
in
tcMethodBind noDefmExpr inst_ty default_binds (sel_id, idx)
) `thenTc` \ (defm_bind, insts_needed, (_, local_defm_id)) ->
-- CHECK THE CONTEXT OF THE DEFAULT-METHOD BINDS
tcSimplifyAndCheck
clas_tyvar_set
avail_insts
insts_needed `thenTc` \ (const_lie, dict_binds) ->
let
defm_binds = AbsBinds
[clas_tyvar]
[this_dict_id]
(local_defm_ids `zip` map RealId default_method_ids)
dict_binds
(RecBind default_binds')
[([clas_tyvar], RealId defm_id, local_defm_id)]
(dict_binds `AndMonoBinds` defm_bind)
in
returnTc (const_lie, defm_binds)
where
inst_ty = mkTyVarTy clas_tyvar
mk_method defm_id = newMethod origin (RealId defm_id) [inst_ty]
origin = ClassDeclOrigin
==================
@makeClassDeclDefaultMethodRhs@ builds the default method for a
class declaration when no explicit default method is given.
\begin{code}
makeClassDeclDefaultMethodRhs
:: Class
-> [TcIdOcc s]
-> Int
-> NF_TcM s (TcExpr s)
makeClassDeclDefaultMethodRhs clas method_ids tag
= -- Return the expression
-- error ty "No default method for ..."
-- The interesting thing is that method_ty is a for-all type;
-- this is fun, although unusual in a type application!
returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tcIdType method_id])
(HsLitOut (HsString (_PK_ error_msg)) stringTy))
where
(
clas_
mod, clas_name) = modAndOcc clas
method_id = method_ids !! (tag-1)
class_op = (classOps clas) !! (tag-1)
error_msg = _UNPK_ (nameString (getName clas))
++ (ppShow 80 (
ppr PprForUser clas
s_op))
-- ++ "\"" Don't know what this trailing quote is for!
clas_
tyvar_set = unitTyVarSet clas_tyvar
inst_ty = mkTyVarTy clas_tyvar
origin = ClassDeclOrigin
noDefmExpr _ = HsApp (HsVar (getName nO_DEFAULT_METHOD_ERROR_ID))
(HsLit (HsString (_PK_ error_msg)))
error_msg = show (sep [text "Class",
ppr PprForUser clas
,
text "Method", ppr PprForUser sel_id])
\end{code}
Contexts
~~~~~~~~
\begin{code}
classDeclCtxt class_name sty
=
ppCat [ppPStr
SLIT("In the class declaration for"), ppr sty class_name]
=
hsep [ptext
SLIT("In the class declaration for"), ppr sty class_name]
\end{code}
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment