InstOrigin(..), OverloadedLit(..),
SYN_IE(LIE), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs,
+ pprLIE, pprLIEInFull,
SYN_IE(InstanceMapper),
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) )
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-} )
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}
%************************************************************************
\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
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}
%************************************************************************
%************************************************************************
\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
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)
(_, 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}
-- 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}
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(..) )
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,
)
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 )
\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 $
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
`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
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
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.
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}
\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))
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}
%************************************************************************
\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}
projects / ghc-hetmet.git / commitdiff