Skip to content
Snippets Groups Projects
Commit 2a3b1705 authored by sof's avatar sof
Browse files

[project @ 1997-07-05 02:43:52 by sof]

parent 788324b2
No related merge requests found
Hide whitespace changes
Inline Side-by-side
ghc/compiler/typecheck/Inst.lhs
+ 74
− 67
View file @ 2a3b1705
......@@ -11,6 +11,7 @@ module Inst (
InstOrigin(..), OverloadedLit(..),
SYN_IE(LIE), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs,
pprLIE, pprLIEInFull,
SYN_IE(InstanceMapper),
......@@ -44,10 +45,10 @@ import TcEnv ( tcLookupGlobalValueByKey, tcLookupTyConByKey )
import TcType ( SYN_IE(TcType), SYN_IE(TcRhoType), TcMaybe, SYN_IE(TcTyVarSet),
tcInstType, zonkTcType, tcSplitForAllTy, tcSplitRhoTy )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
import Bag ( emptyBag, unitBag, unionBags, unionManyBags, bagToList,
listToBag, consBag, Bag )
import Class ( classInstEnv,
SYN_IE(Class), GenClass, SYN_IE(ClassInstEnv), SYN_IE(ClassOp)
SYN_IE(Class), GenClass, SYN_IE(ClassInstEnv)
)
import ErrUtils ( addErrLoc, SYN_IE(Error) )
import Id ( GenId, idType, mkInstId, SYN_IE(Id) )
......@@ -68,7 +69,7 @@ import Type ( GenType, eqSimpleTy, instantiateTy,
import TyVar ( unionTyVarSets, GenTyVar )
import TysPrim ( intPrimTy )
import TysWiredIn ( intDataCon, integerTy )
import Unique ( showUnique, fromRationalClassOpKey, rationalTyConKey,
import Unique ( fromRationalClassOpKey, rationalTyConKey,
fromIntClassOpKey, fromIntegerClassOpKey, Unique
)
import Util ( panic, zipEqual, zipWithEqual, assoc, assertPanic, pprTrace{-ToDo:rm-} )
......@@ -94,6 +95,16 @@ plusLIEs lies = unionManyBags lies
zonkLIE :: LIE s -> NF_TcM s (LIE s)
zonkLIE lie = mapBagNF_Tc zonkInst lie
pprLIE :: PprStyle -> LIE s -> Doc
pprLIE sty lie = pprQuote sty $ \ sty ->
braces (hsep (punctuate comma (map (pprInst sty) (bagToList lie))))
pprLIEInFull sty insts
= vcat (map go (bagToList insts))
where
go inst = ppr sty inst <+> pprOrigin sty inst
\end{code}
%************************************************************************
......@@ -365,29 +376,23 @@ relevant in error messages.
\begin{code}
instance Outputable (Inst s) where
ppr sty inst = pprQuote sty (\ sty -> ppr_inst sty (\ o l -> empty) inst)
pprInst sty inst = ppr_inst sty (\ o l -> pprOrigin o l sty) inst
ppr_inst sty ppr_orig (LitInst u lit ty orig loc)
= hang (ppr_orig orig loc)
4 (hsep [case lit of
OverloadedIntegral i -> integer i
OverloadedFractional f -> rational f,
ptext SLIT("at"),
ppr sty ty,
show_uniq sty u])
ppr_inst sty ppr_orig (Dict u clas ty orig loc)
= hang (ppr_orig orig loc)
4 (pprQuote sty $ \ sty ->
hsep [ppr sty clas, pprParendGenType sty ty, show_uniq sty u])
ppr_inst sty ppr_orig (Method u id tys rho orig loc)
= hang (ppr_orig orig loc)
4 (hsep [ppr sty id, ptext SLIT("at"),
pprQuote sty $ \ sty -> interppSP sty tys,
show_uniq sty u])
ppr sty inst = pprQuote sty (\ sty -> pprInst sty inst)
pprInst sty (LitInst u lit ty orig loc)
= hsep [case lit of
OverloadedIntegral i -> integer i
OverloadedFractional f -> rational f,
ptext SLIT("at"),
ppr sty ty,
show_uniq sty u]
pprInst sty (Dict u clas ty orig loc)
= hsep [ppr sty clas, pprParendGenType sty ty, show_uniq sty u]
pprInst sty (Method u id tys rho orig loc)
= hsep [ppr sty id, ptext SLIT("at"),
interppSP sty tys,
show_uniq sty u]
show_uniq PprDebug u = ppr PprDebug u
show_uniq sty u = empty
......@@ -396,7 +401,7 @@ show_uniq sty u = empty
Printing in error messages
\begin{code}
noInstanceErr inst sty = hang (ptext SLIT("No instance for:")) 4 (ppr sty inst)
noInstanceErr inst sty = ptext SLIT("No instance for:") <+> ppr sty inst
\end{code}
%************************************************************************
......@@ -406,7 +411,7 @@ noInstanceErr inst sty = hang (ptext SLIT("No instance for:")) 4 (ppr sty inst)
%************************************************************************
\begin{code}
type InstanceMapper = Class -> (ClassInstEnv, ClassOp -> SpecEnv)
type InstanceMapper = Class -> ClassInstEnv
\end{code}
A @ClassInstEnv@ lives inside a class, and identifies all the instances
......@@ -434,7 +439,7 @@ lookupInst :: Inst s
lookupInst dict@(Dict _ clas ty orig loc)
= case lookupMEnv matchTy (get_inst_env clas orig) ty of
Nothing -> tcAddSrcLoc loc $
tcAddErrCtxt (pprOrigin orig loc) $
tcAddErrCtxt (\sty -> pprOrigin sty dict) $
failTc (noInstanceErr dict)
Just (dfun_id, tenv)
......@@ -511,8 +516,8 @@ lookupSimpleInst class_inst_env clas ty
(_, theta, _) = splitSigmaTy (idType dfun)
noSimpleInst clas ty sty
= sep [ptext SLIT("No instance for class"), ppr sty clas,
ptext SLIT("at type"), ppr sty ty]
= ptext SLIT("No instance for") <+>
(pprQuote sty $ \ sty -> ppr sty clas <+> ppr sty ty)
\end{code}
......@@ -635,44 +640,46 @@ 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)
= inst_mapper clas
get_inst_env clas other_orig = classInstEnv clas
pprOrigin :: InstOrigin s -> SrcLoc -> Error
pprOrigin orig locn sty
= hsep [text "arising from", pp_orig, text "at", ppr sty locn]
pprOrigin :: PprStyle -> Inst s -> Doc
pprOrigin sty inst
= hsep [text "arising from", pp_orig orig, text "at", ppr sty locn]
where
pp_orig
= case orig of
OccurrenceOf id ->
hsep [ptext SLIT("use of"), ppr sty id]
OccurrenceOfCon id ->
hsep [ptext SLIT("use of"), ppr sty id]
LiteralOrigin lit ->
hsep [ptext SLIT("the literal"), ppr sty lit]
InstanceDeclOrigin ->
ptext SLIT("an instance declaration")
ArithSeqOrigin seq ->
hsep [ptext SLIT("the arithmetic sequence:"), ppr sty seq]
SignatureOrigin ->
ptext SLIT("a type signature")
DoOrigin ->
ptext SLIT("a do statement")
ClassDeclOrigin ->
ptext SLIT("a class declaration")
InstanceSpecOrigin _ clas ty ->
hsep [text "a SPECIALIZE instance pragma; class",
ppr sty clas, text "type:", ppr sty ty]
ValSpecOrigin name ->
hsep [ptext SLIT("a SPECIALIZE user-pragma for"), ppr sty name]
CCallOrigin clabel Nothing{-ccall result-} ->
hsep [ptext SLIT("the result of the _ccall_ to"), text clabel]
CCallOrigin clabel (Just arg_expr) ->
hsep [ptext SLIT("an argument in the _ccall_ to"), text clabel <> comma, text "namely", ppr sty arg_expr]
LitLitOrigin s ->
hcat [ptext SLIT("the ``literal-literal''"), text s]
UnknownOrigin ->
ptext SLIT("...oops -- I don't know where the overloading came from!")
(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!")
\end{code}
ghc/compiler/typecheck/TcBinds.lhs
+ 17
− 13
View file @ 2a3b1705
......@@ -106,14 +106,14 @@ dictionaries, which we resolve at the module level.
\begin{code}
tcBindsAndThen
:: (TcHsBinds s -> thing -> thing) -- Combinator
:: (RecFlag -> TcMonoBinds s -> thing -> thing) -- Combinator
-> RenamedHsBinds
-> TcM s (thing, LIE s)
-> TcM s (thing, LIE s)
tcBindsAndThen combiner EmptyBinds do_next
= do_next `thenTc` \ (thing, lie) ->
returnTc (combiner EmptyBinds thing, lie)
returnTc (combiner nonRecursive EmptyMonoBinds thing, lie)
tcBindsAndThen combiner (ThenBinds binds1 binds2) do_next
= tcBindsAndThen combiner binds1 (tcBindsAndThen combiner binds2 do_next)
......@@ -146,17 +146,17 @@ tcBindsAndThen combiner (MonoBind bind sigs is_rec) do_next
-- All done
let
final_lie = lie2 `plusLIE` poly_lie
final_binds = MonoBind poly_binds [] is_rec `ThenBinds`
MonoBind inst_mbinds [] nonRecursive `ThenBinds`
prag_binds
final_thing = combiner is_rec poly_binds $
combiner nonRecursive inst_mbinds $
combiner nonRecursive prag_binds
thing
in
returnTc (prag_info_fn, (combiner final_binds thing, final_lie))
returnTc (prag_info_fn, (final_thing, final_lie))
) `thenTc` \ (_, result) ->
returnTc result
where
binder_names = map fst (bagToList (collectMonoBinders bind))
ty_sigs = [sig | sig@(Sig name _ _) <- sigs]
\end{code}
An aside. The original version of @tcBindsAndThen@ which lacks a
......@@ -494,10 +494,14 @@ been instantiated.
\begin{code}
data TcSigInfo s
= TySigInfo Name
(TcIdBndr s) -- *Polymorphic* binder for this value...
[TcTyVar s] (TcThetaType s) (TcTauType s)
SrcLoc
= TySigInfo
Name -- N, the Name in corresponding binding
(TcIdBndr s) -- *Polymorphic* binder for this value...
-- Usually has name = N, but doesn't have to.
[TcTyVar s]
(TcThetaType s)
(TcTauType s)
SrcLoc
maybeSig :: [TcSigInfo s] -> Name -> Maybe (TcSigInfo s)
......@@ -646,11 +650,11 @@ moving them into place as is done for type signatures.
\begin{code}
tcPragmaSigs :: [RenamedSig] -- The pragma signatures
-> TcM s (Name -> PragmaInfo, -- Maps name to the appropriate PragmaInfo
TcHsBinds s,
TcMonoBinds s,
LIE s)
-- For now we just deal with INLINE pragmas
tcPragmaSigs sigs = returnTc (prag_fn, EmptyBinds, emptyLIE )
tcPragmaSigs sigs = returnTc (prag_fn, EmptyMonoBinds, emptyLIE )
where
prag_fn name | any has_inline sigs = IWantToBeINLINEd
| otherwise = NoPragmaInfo
......
ghc/compiler/typecheck/TcClassDcl.lhs
+ 81
− 77
View file @ 2a3b1705
......@@ -14,7 +14,7 @@ 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,
SYN_IE(RecFlag), nonRecursive, andMonoBinds, collectMonoBinders,
Stmt, DoOrListComp, ArithSeqInfo, InPat, Fake )
import HsTypes ( getTyVarName )
import HsPragmas ( ClassPragmas(..) )
......@@ -28,18 +28,19 @@ 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 ( tcMethodBind )
import TcBinds ( tcBindWithSigs, TcSigInfo(..) )
import TcKind ( unifyKind, TcKind )
import TcMonad
import TcMonoType ( tcHsType, tcContext )
import TcSimplify ( tcSimplifyAndCheck )
import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars, tcInstSigType )
import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars,
tcInstSigType, tcInstSigTcType )
import PragmaInfo ( PragmaInfo(..) )
import Bag ( foldBag, unionManyBags )
import Class ( GenClass, GenClassOp, mkClass, mkClassOp, classBigSig,
classOps, classOpString, classOpLocalType, classDefaultMethodId,
classOpTagByOccName, SYN_IE(ClassOp), SYN_IE(Class)
import Bag ( bagToList )
import Class ( GenClass, mkClass, classBigSig,
classDefaultMethodId,
classOpTagByOccName, SYN_IE(Class)
)
import CmdLineOpts ( opt_PprUserLength )
import Id ( GenId, mkSuperDictSelId, mkMethodSelId,
......@@ -48,15 +49,14 @@ import Id ( GenId, mkSuperDictSelId, mkMethodSelId,
)
import CoreUnfold ( getUnfoldingTemplate )
import IdInfo
import Name ( Name, isLocallyDefined, moduleString,
import Name ( Name, isLocallyDefined, moduleString, getSrcLoc,
nameString, NamedThing(..) )
import Outputable
import PrelVals ( nO_DEFAULT_METHOD_ERROR_ID )
import Pretty
import PprType ( GenClass, GenType, GenTyVar, GenClassOp )
import PprType ( GenClass, GenType, GenTyVar )
import SpecEnv ( SpecEnv )
import SrcLoc ( mkGeneratedSrcLoc )
import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, splitRhoTy,
mkForAllTy, mkSigmaTy, splitSigmaTy, SYN_IE(Type)
)
import TysWiredIn ( stringTy )
......@@ -107,7 +107,7 @@ Death to "ExpandingDicts".
\begin{code}
tcClassDecl1 rec_inst_mapper
tcClassDecl1 rec_env rec_inst_mapper
(ClassDecl context class_name
tyvar_name class_sigs def_methods pragmas src_loc)
= tcAddSrcLoc src_loc $
......@@ -117,7 +117,7 @@ tcClassDecl1 rec_inst_mapper
tcLookupClass class_name `thenTc` \ (class_kind, rec_class) ->
tcLookupTyVar (getTyVarName tyvar_name) `thenNF_Tc` \ (tyvar_kind, rec_tyvar) ->
let
(rec_class_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_class
rec_class_inst_env = rec_inst_mapper rec_class
in
-- FORCE THE CLASS AND ITS TYVAR TO HAVE SAME KIND
......@@ -128,14 +128,14 @@ tcClassDecl1 rec_inst_mapper
`thenTc` \ (scs, sc_sel_ids) ->
-- CHECK THE CLASS SIGNATURES,
mapTc (tcClassSig rec_class rec_tyvar rec_class_op_inst_fn) class_sigs
mapTc (tcClassSig rec_env rec_class rec_tyvar) class_sigs
`thenTc` \ sig_stuff ->
-- MAKE THE CLASS OBJECT ITSELF
let
(ops, op_sel_ids, defm_ids) = unzip3 sig_stuff
(op_sel_ids, defm_ids) = unzip sig_stuff
clas = mkClass (uniqueOf class_name) (getName class_name) rec_tyvar
scs sc_sel_ids ops op_sel_ids defm_ids
scs sc_sel_ids op_sel_ids defm_ids
rec_class_inst_env
in
returnTc clas
......@@ -144,8 +144,7 @@ tcClassDecl1 rec_inst_mapper
let
clas_ty = mkTyVarTy clas_tyvar
dict_component_tys = [mkDictTy sc clas_ty | sc <- scs] ++
[classOpLocalType op | op <- ops])
dict_component_tys = classDictArgTys clas_ty
new_or_data = case dict_component_tys of
[_] -> NewType
other -> DataType
......@@ -203,20 +202,18 @@ tcClassContext rec_class rec_tyvar context pragmas
returnTc (mkSuperDictSelId uniq rec_class super_class ty)
tcClassSig :: Class -- Knot tying only!
tcClassSig :: TcEnv s -- Knot tying only!
-> Class -- ...ditto...
-> TyVar -- The class type variable, used for error check only
-> (ClassOp -> SpecEnv) -- Ditto; the spec info for the class ops
-> RenamedClassOpSig
-> TcM s (ClassOp, -- class op
Id, -- selector id
Id) -- default-method ids
-> TcM s (Id, -- selector id
Maybe Id) -- default-method ids
tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn
(ClassOpSig op_name dm_name
tcClassSig rec_env rec_clas rec_clas_tyvar
(ClassOpSig op_name maybe_dm_name
op_ty
src_loc)
= tcAddSrcLoc src_loc $
fixTc ( \ ~(_, rec_sel_id, rec_defm_id) -> -- Knot for pragmas
-- Check the type signature. NB that the envt *already has*
-- bindings for the type variables; see comments in TcTyAndClassDcls.
......@@ -228,21 +225,19 @@ tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn
global_ty = mkSigmaTy [rec_clas_tyvar]
[(rec_clas, mkTyVarTy rec_clas_tyvar)]
local_ty
class_op_nm = getOccName op_name
class_op = mkClassOp class_op_nm
(classOpTagByOccName rec_clas{-yeeps!-} class_op_nm)
local_ty
in
-- Build the selector id and default method id
let
sel_id = mkMethodSelId op_name rec_clas class_op global_ty
defm_id = mkDefaultMethodId dm_name rec_clas class_op False global_ty
-- ToDo: improve the "False"
sel_id = mkMethodSelId op_name rec_clas global_ty
maybe_dm_id = case maybe_dm_name of
Nothing -> Nothing
Just dm_name -> let
dm_id = mkDefaultMethodId dm_name rec_clas global_ty
in
Just (tcAddImportedIdInfo rec_env dm_id)
in
tcAddImportedIdInfo defm_id `thenNF_Tc` \ final_defm_id ->
returnTc (class_op, sel_id, final_defm_id)
)
returnTc (sel_id, maybe_dm_id)
\end{code}
......@@ -270,40 +265,39 @@ each local class decl.
\begin{code}
tcClassDecls2 :: [RenamedHsDecl]
-> NF_TcM s (LIE s, TcHsBinds s)
-> NF_TcM s (LIE s, TcMonoBinds s)
tcClassDecls2 decls
= foldr combine
(returnNF_Tc (emptyLIE, EmptyBinds))
(returnNF_Tc (emptyLIE, EmptyMonoBinds))
[tcClassDecl2 cls_decl | ClD cls_decl <- decls]
where
combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
tc2 `thenNF_Tc` \ (lie2, binds2) ->
returnNF_Tc (lie1 `plusLIE` lie2,
binds1 `ThenBinds` binds2)
binds1 `AndMonoBinds` binds2)
\end{code}
@tcClassDecl2@ is the business end of things.
\begin{code}
tcClassDecl2 :: RenamedClassDecl -- The class declaration
-> NF_TcM s (LIE s, TcHsBinds s)
-> NF_TcM s (LIE s, TcMonoBinds s)
tcClassDecl2 (ClassDecl context class_name
tyvar_name class_sigs default_binds pragmas src_loc)
| not (isLocallyDefined class_name)
= returnNF_Tc (emptyLIE, EmptyBinds)
= returnNF_Tc (emptyLIE, EmptyMonoBinds)
| otherwise -- It is locally defined
= recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
tcAddSrcLoc src_loc $
= recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
tcAddSrcLoc src_loc $
-- Get the relevant class
tcLookupClass class_name `thenTc` \ (_, clas) ->
let
(tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
= classBigSig clas
(tyvar, scs, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
-- The selector binds are already in the selector Id's unfoldings
sel_binds = [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
......@@ -311,17 +305,13 @@ tcClassDecl2 (ClassDecl context class_name
isLocallyDefined sel_id
]
final_sel_binds = MonoBind (andMonoBinds sel_binds) [] nonRecursive
final_sel_binds = andMonoBinds sel_binds
in
-- Generate bindings for the default methods
tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], _, _) ->
mapAndUnzipTc (buildDefaultMethodBind clas clas_tyvar default_binds)
(op_sel_ids `zip` [0..])
`thenTc` \ (const_insts_s, meth_binds) ->
returnTc (unionManyBags const_insts_s,
final_sel_binds `ThenBinds`
MonoBind (andMonoBinds meth_binds) [] nonRecursive)
buildDefaultMethodBinds clas default_binds `thenTc` \ (const_insts, meth_binds) ->
returnTc (const_insts,
final_sel_binds `AndMonoBinds` meth_binds)
\end{code}
%************************************************************************
......@@ -398,48 +388,62 @@ dfun.Foo.List
\end{verbatim}
\begin{code}
buildDefaultMethodBind
buildDefaultMethodBinds
:: Class
-> TcTyVar s
-> RenamedMonoBinds
-> (Id, Int)
-> TcM s (LIE s, TcMonoBinds s)
buildDefaultMethodBind clas clas_tyvar default_binds (sel_id, idx)
= newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
buildDefaultMethodBinds clas default_binds
= -- Construct suitable signatures
tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], [inst_ty], inst_env) ->
let
avail_insts = this_dict
defm_id = classDefaultMethodId clas idx
no_prags name = NoPragmaInfo -- No pragmas yet for default methods
mk_sig (bndr_name, locn)
= let
idx = classOpTagByOccName clas (getOccName bndr_name) - 1
sel_id = op_sel_ids !! idx
Just dm_id = defm_ids !! idx
in
newMethod origin (RealId sel_id) [inst_ty] `thenNF_Tc` \ meth@(_, TcId local_dm_id) ->
tcInstSigTcType (idType local_dm_id) `thenNF_Tc` \ (tyvars', rho_ty') ->
let
(theta', tau') = splitRhoTy rho_ty'
sig_info = TySigInfo bndr_name local_dm_id tyvars' theta' tau' locn
in
returnNF_Tc (sig_info, ([clas_tyvar], RealId dm_id, TcId local_dm_id))
in
mapAndUnzipNF_Tc mk_sig bndrs `thenNF_Tc` \ (sigs, abs_bind_stuff) ->
-- Typecheck the default bindings
let
clas_tyvar_set = unitTyVarSet clas_tyvar
in
tcExtendGlobalTyVars clas_tyvar_set (
tcMethodBind noDefmExpr inst_ty no_prags default_binds (sel_id, idx)
) `thenTc` \ (defm_bind, insts_needed, (_, local_defm_id)) ->
tcBindWithSigs (map fst bndrs) default_binds sigs nonRecursive (\_ -> NoPragmaInfo)
) `thenTc` \ (defm_binds, insts_needed, _) ->
-- CHECK THE CONTEXT OF THE DEFAULT-METHOD BINDS
-- Check the context
newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
let
avail_insts = this_dict
in
tcSimplifyAndCheck
clas_tyvar_set
avail_insts
insts_needed `thenTc` \ (const_lie, dict_binds) ->
let
defm_binds = AbsBinds
full_binds = AbsBinds
[clas_tyvar]
[this_dict_id]
[([clas_tyvar], RealId defm_id, local_defm_id)]
(dict_binds `AndMonoBinds` defm_bind)
abs_bind_stuff
(dict_binds `AndMonoBinds` defm_binds)
in
returnTc (const_lie, defm_binds)
returnTc (const_lie, full_binds)
where
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 opt_PprUserLength) clas,
text "Method", ppr (PprForUser opt_PprUserLength) sel_id])
(tyvar, scs, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
origin = ClassDeclOrigin
bndrs = bagToList (collectMonoBinders default_binds)
\end{code}
......
ghc/compiler/typecheck/TcDeriv.lhs
+ 19
− 19
View file @ 2a3b1705
......@@ -244,11 +244,10 @@ tcDeriving modname rn_name_supply inst_decl_infos_in
rn_one meth_binds = newDfunName Nothing mkGeneratedSrcLoc `thenRn` \ dfun_name ->
rnMethodBinds meth_binds `thenRn` \ rn_meth_binds ->
returnRn (dfun_name, rn_meth_binds)
in
mapTc (gen_inst_info modname)
(new_inst_infos `zip` dfun_names_w_method_binds) `thenTc` \ really_new_inst_infos ->
let
really_new_inst_infos = map (gen_inst_info modname)
(new_inst_infos `zip` dfun_names_w_method_binds)
ddump_deriv = ddump_deriving really_new_inst_infos rn_extra_binds
in
--pprTrace "derived:\n" (ddump_deriv PprDebug) $
......@@ -441,7 +440,7 @@ solveDerivEqns inst_decl_infos_in orig_eqns
add_solns inst_decl_infos_in orig_eqns current_solns
`thenTc` \ (new_inst_infos, inst_mapper) ->
let
class_to_inst_env cls = fst (inst_mapper cls)
class_to_inst_env cls = inst_mapper cls
in
-- Simplify each RHS
......@@ -480,7 +479,9 @@ add_solns :: Bag InstInfo -- The global, non-derived ones
-- because we need the LHS info for addClassInstance.
add_solns inst_infos_in eqns solns
= buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper ->
= discardErrsTc (buildInstanceEnvs all_inst_infos) `thenTc` \ inst_mapper ->
-- We do the discard-errs so that we don't get repeated error messages
-- about missing or duplicate instances.
returnTc (new_inst_infos, inst_mapper)
where
new_inst_infos = zipWithEqual "add_solns" mk_deriv_inst_info eqns solns
......@@ -605,25 +606,24 @@ gen_bind (InstInfo clas _ ty _ _ _ _ _ _)
gen_inst_info :: Module -- Module name
-> (InstInfo, (Name, RenamedMonoBinds)) -- the main stuff to work on
-> TcM s InstInfo -- the gen'd (filled-in) "instance decl"
-> InstInfo -- the gen'd (filled-in) "instance decl"
gen_inst_info modname
(InstInfo clas tyvars ty inst_decl_theta _ _ _ locn _, (dfun_name, meth_binds))
=
-- Generate the various instance-related Ids
mkInstanceRelatedIds
dfun_name
clas tyvars ty
inst_decl_theta
`thenNF_Tc` \ (dfun_id, dfun_theta) ->
returnTc (InstInfo clas tyvars ty inst_decl_theta
dfun_theta dfun_id
meth_binds
locn [])
InstInfo clas tyvars ty inst_decl_theta
dfun_theta dfun_id
meth_binds
locn []
where
from_here = isLocallyDefined tycon
(tycon,_,_) = getAppDataTyCon ty
(dfun_id, dfun_theta) = mkInstanceRelatedIds
dfun_name
clas tyvars ty
inst_decl_theta
from_here = isLocallyDefined tycon
(tycon,_,_) = getAppDataTyCon ty
\end{code}
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment