mkHsTyLam, mkHsTyApp,
mkHsDictLam, mkHsDictApp )
-import TcBinds ( tcBindWithSigs, TcSigInfo(..) )
+import TcBinds ( tcBindWithSigs, tcPragmaSigs, TcSigInfo(..) )
import TcMonad
import RnMonad ( SYN_IE(RnNameSupply) )
import Inst ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
classBigSig, classOps, classOpLocalType,
classDefaultMethodId, SYN_IE(Class)
)
-import Id ( GenId, idType, isDefaultMethodId_maybe,
+import Id ( GenId, idType, isDefaultMethodId_maybe, replacePragmaInfo,
isNullaryDataCon, dataConArgTys, SYN_IE(Id) )
import ListSetOps ( minusList )
import Maybes ( maybeToBool, expectJust, seqMaybe )
-import Name ( nameOccName, getOccString, occNameString, moduleString, getOccName,
+import Name ( nameOccName, getOccString, occNameString, moduleString,
isLocallyDefined, OccName, Name{--O only-}, SYN_IE(Module),
NamedThing(..)
)
import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
pprParendGenType
)
-import PprStyle
import Outputable
import SrcLoc ( SrcLoc, noSrcLoc )
import Pretty
-import TyCon ( isSynTyCon, derivedFor )
+import TyCon ( isSynTyCon, isDataTyCon, derivedClasses )
import Type ( GenType(..), SYN_IE(ThetaType), mkTyVarTys, isPrimType,
splitSigmaTy, splitAppTys, isTyVarTy, matchTy, mkSigmaTy,
- getTyCon_maybe, maybeAppTyCon, SYN_IE(Type),
+ getTyCon_maybe, maybeAppTyCon, SYN_IE(Type), getTyVar,
maybeBoxedPrimType, maybeAppDataTyCon, splitRhoTy, eqTy
)
import TyVar ( GenTyVar, SYN_IE(GenTyVarSet), tyVarSetToList,
mkTyVarSet, unionTyVarSets, SYN_IE(TyVar) )
import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
import TysWiredIn ( stringTy )
-import Unique ( Unique, cCallableClassKey, cReturnableClassKey )
-import UniqFM ( Uniquable(..) )
-import Util ( zipEqual, panic, pprPanic, pprTrace
+import Unique ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
+import Util ( zipEqual, panic, pprPanic, pprTrace, removeDups, Ord3(..),
#if __GLASGOW_HASKELL__ < 202
, trace
#endif
other -> ([], [], poly_ty)
(class_name, inst_ty) = case dict_ty of
MonoDictTy cls ty -> (cls,ty)
- other -> pprPanic "Malformed intance decl" (ppr PprDebug poly_ty)
+ other -> pprPanic "Malformed instance decl" (ppr PprDebug poly_ty)
\end{code}
newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
newDicts origin [(clas,inst_ty')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
+ -- Now process any INLINE or SPECIALIZE pragmas for the methods
+ -- ...[NB May 97; all ignored except INLINE]
+ tcPragmaSigs uprags `thenTc` \ (prag_fn, spec_binds, spec_lie) ->
+
-- Check the method bindings
let
inst_tyvars_set' = mkTyVarSet inst_tyvars'
in
mapTc check_from_this_class (bagToList (collectMonoBinders monobinds)) `thenTc_`
tcExtendGlobalTyVars inst_tyvars_set' (
- mapAndUnzip3Tc (tcMethodBind (getDefmRhs clas) inst_ty' monobinds)
+ mapAndUnzip3Tc (tcMethodBind (getDefmRhs clas) inst_ty' prag_fn monobinds)
(op_sel_ids `zip` [0..])
) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
avail_insts -- These insts are in scope; quite a few, eh?
= this_dict `plusLIE` dfun_arg_dicts `plusLIE` unionManyBags meth_lies
in
- tcAddErrCtxt (bindSigCtxt meth_ids) (
- tcSimplifyAndCheck
+ tcAddErrCtxt bindSigCtxt (
+ tcSimplifyAndCheck
inst_tyvars_set' -- Local tyvars
avail_insts
(sc_dicts `unionBags`
-- Ignore the result; we're only doing
-- this to make sure it can be done.
- -- Now process any SPECIALIZE pragmas for the methods
- let
- spec_sigs = [ s | s@(SpecSig _ _ _ _) <- uprags ]
- in
- tcPragmaSigs spec_sigs `thenTc` \ (_, spec_binds, spec_lie) ->
-
-- Create the result bindings
let
dict_bind = VarMonoBind this_dict_id (Dictionary sc_dict_ids meth_ids)
tcMethodBind
:: (Int -> RenamedHsExpr) -- Function mapping a tag to default RHS
-> TcType s -- Instance type
+ -> (Name -> PragmaInfo)
-> RenamedMonoBinds -- Method binding
-> (Id, Int) -- Selector ID (and its 0-indexed tag)
-- for which binding is wanted
-> TcM s (TcMonoBinds s, LIE s, (LIE s, TcIdOcc s))
-tcMethodBind deflt_fn inst_ty meth_binds (sel_id, idx)
+tcMethodBind deflt_fn inst_ty prag_fn meth_binds (sel_id, idx)
= newMethod origin (RealId sel_id) [inst_ty] `thenNF_Tc` \ meth@(_, TcId meth_id) ->
tcInstSigTcType (idType meth_id) `thenNF_Tc` \ (tyvars', rho_ty') ->
let
Just stuff -> stuff
Nothing -> (meth_name, default_bind)
- (theta', tau') = splitRhoTy rho_ty'
- sig_info = TySigInfo op_name meth_id tyvars' theta' tau' noSrcLoc
+ (theta', tau') = splitRhoTy rho_ty'
+ meth_id_w_prags = replacePragmaInfo meth_id (prag_fn meth_name)
+ sig_info = TySigInfo op_name meth_id_w_prags tyvars' theta' tau' noSrcLoc
in
tcBindWithSigs [op_name] op_bind [sig_info]
nonRecursive (\_ -> NoPragmaInfo) `thenTc` \ (binds, insts, _) ->
= returnTc (inst_tycon,arg_tys)
-- TYVARS CHECK
- | not (all isTyVarTy arg_tys ||
- opt_GlasgowExts)
+ | not (opt_GlasgowExts ||
+ (all isTyVarTy arg_tys && null tyvar_dups)
+ )
= failTc (instTypeErr inst_tau)
-- DERIVING CHECK
-- for something that we are also planning to `derive'
-- Though we can have an explicit instance which is more
-- specific than the derived instance
- | clas `derivedFor` inst_tycon
+ | clas `elem` (derivedClasses inst_tycon)
&& all isTyVarTy arg_tys
= failTc (derivingWhenInstanceExistsErr clas inst_tycon)
(possible_tycon, arg_tys) = splitAppTys inst_tau
inst_tycon_maybe = getTyCon_maybe possible_tycon
inst_tycon = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
+ (_, tyvar_dups) = removeDups cmp (map (getTyVar "tcInstDecls1:getTyVarTy") arg_tys)
-- These conditions come directly from what the DsCCall is capable of.
-- Totally grotesque. Green card should solve this.
byte_arr_thing
where
byte_arr_thing = case maybeAppDataTyCon ty of
- Just (tycon, ty_args, [data_con]) ->
--- pprTrace "cc1" (sep [ppr PprDebug tycon, ppr PprDebug data_con,
--- sep (map (ppr PprDebug) data_con_arg_tys)])(
+ Just (tycon, ty_args, [data_con]) | isDataTyCon tycon ->
length data_con_arg_tys == 2 &&
maybeToBool maybe_arg2_tycon &&
--- pprTrace "cc2" (sep [ppr PprDebug arg2_tycon]) (
(arg2_tycon == byteArrayPrimTyCon ||
arg2_tycon == mutableByteArrayPrimTyCon)
--- ))
where
data_con_arg_tys = dataConArgTys data_con ty_args
(data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
instTypeErr ty sty
= case ty of
- SynTy tc _ _ -> hcat [ptext SLIT("The type synonym `"), ppr sty tc, rest_of_msg]
- TyVarTy tv -> hcat [ptext SLIT("The type variable `"), ppr sty tv, rest_of_msg]
- other -> hcat [ptext SLIT("The type `"), ppr sty ty, rest_of_msg]
+ SynTy tc _ _ -> hsep [ptext SLIT("The type synonym"), ppr sty tc, rest_of_msg]
+ TyVarTy tv -> hsep [ptext SLIT("The type variable"), ppr sty tv, rest_of_msg]
+ other -> hsep [ptext SLIT("The type"), ppr sty ty, rest_of_msg]
where
- rest_of_msg = ptext SLIT("' cannot be used as an instance type.")
+ rest_of_msg = ptext SLIT("cannot be used as an instance type")
instBndrErr bndr clas sty
= hsep [ptext SLIT("Class"), ppr sty clas, ptext SLIT("does not have a method"), ppr sty bndr]
ppr sty name, ptext SLIT("to its signature :") ])
4 (ppr sty ty)
-bindSigCtxt method_ids sty
- = hang (ptext SLIT("When checking type signatures for: "))
- 4 (hsep (punctuate comma (map (ppr sty) method_ids)))
+bindSigCtxt sty
+ = ptext SLIT("When checking methods of an instance declaration")
superClassSigCtxt sty
- = ptext SLIT("When checking superclass constraints on instance declaration")
+ = ptext SLIT("When checking superclass constraints of an instance declaration")
\end{code}
projects / ghc-hetmet.git / blobdiff