isClassOpSig, isPragSig,
placeHolderType
)
-import BasicTypes ( RecFlag(..), StrictnessMark(..) )
+import BasicTypes ( RecFlag(..) )
import RnHsSyn ( RenamedTyClDecl, RenamedSig,
RenamedClassOpSig, RenamedMonoBinds,
maybeGenericMatch
import Inst ( Inst, InstOrigin(..), instToId, newDicts, newMethod )
import TcEnv ( TyThingDetails(..),
- tcLookupClass, tcExtendTyVarEnv2,
- tcExtendTyVarEnv
+ tcLookupClass, tcExtendLocalValEnv2,
+ tcExtendTyVarEnv2, tcExtendTyVarEnv
)
import TcTyDecls ( tcMkDataCon )
-import TcBinds ( tcMonoBinds )
+import TcBinds ( tcMonoBinds, tcSpecSigs )
import TcMonoType ( TcSigInfo(..), tcHsType, tcHsTheta, mkTcSig )
-import TcSimplify ( tcSimplifyCheck )
+import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import TcUnify ( checkSigTyVars, sigCtxt )
import TcMType ( tcInstTyVars )
import TcType ( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar,
import TyCon ( tyConGenInfo )
import Subst ( substTyWith )
import MkId ( mkDictSelId, mkDefaultMethodId )
-import Id ( Id, idType, idName, mkUserLocal, setIdLocalExported, setInlinePragma )
+import Id ( Id, idType, idName, mkUserLocal, setInlinePragma )
import Name ( Name, NamedThing(..) )
import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv )
import NameSet ( emptyNameSet, unitNameSet )
-import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
- mkSuperDictSelOcc, reportIfUnused )
+import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc, reportIfUnused )
import Outputable
import Var ( TyVar )
import CmdLineOpts
in
tcExtendTyVarEnv tyvars $
- checkDefaultBinds clas op_names def_methods `thenM` \ mb_dm_env ->
+ checkDefaultBinds clas op_names def_methods `thenM` \ mb_dm_env ->
-- CHECK THE CONTEXT
-- The renamer has already checked that the context mentions
tcDefMeth clas tyvars binds_in prags op_item@(sel_id, DefMeth dm_name)
= tcInstTyVars ClsTv tyvars `thenM` \ (clas_tyvars, inst_tys, _) ->
let
- dm_ty = idType sel_id -- Same as dict selector!
- -- The default method's type should really come from the
- -- iface file, since it could be usage-generalised, but this
- -- requires altering the mess of knots in TcModule and I'm
- -- too scared to do that. Instead, I have disabled generalisation
- -- of types of default methods (and dict funs) by annotating them
- -- TyGenNever (in MkId). Ugh! KSW 1999-09.
-
+ dm_ty = idType sel_id -- Same as dict selector!
theta = [mkClassPred clas inst_tys]
local_dm_id = mkDefaultMethodId dm_name dm_ty
xtve = tyvars `zip` clas_tyvars
(sel_id, meth_id, meth_bind)
= -- Check the bindings; first adding inst_tyvars to the envt
-- so that we don't quantify over them in nested places
- mkTcSig meth_id `thenM` \ meth_sig ->
+ mkTcSig meth_id `thenM` \ meth_sig ->
tcExtendTyVarEnv2 xtve (
- addErrCtxt (methodCtxt sel_id) $
- getLIE (tcMonoBinds meth_bind [meth_sig] NonRecursive)
- ) `thenM` \ ((meth_bind, _, _), meth_lie) ->
+ addErrCtxt (methodCtxt sel_id) $
+ getLIE $
+ tcMonoBinds meth_bind [meth_sig] NonRecursive
+ ) `thenM` \ ((meth_bind,_), meth_lie) ->
-- Now do context reduction. We simplify wrt both the local tyvars
-- and the ones of the class/instance decl, so that there is
checkSigTyVars all_tyvars `thenM` \ all_tyvars' ->
let
+ sel_name = idName sel_id
+ inline_prags = [ (is_inl, phase)
+ | InlineSig is_inl name phase _ <- prags,
+ name == sel_name ]
+ spec_prags = [ prag
+ | prag@(SpecSig name _ _) <- prags,
+ name == sel_name]
+
-- Attach inline pragmas as appropriate
(final_meth_id, inlines)
- | (InlineSig inl _ phase _ : _) <- filter is_inline prags
+ | ((is_inline, phase) : _) <- inline_prags
= (meth_id `setInlinePragma` phase,
- if inl then unitNameSet (idName meth_id) else emptyNameSet)
+ if is_inline then unitNameSet (idName meth_id) else emptyNameSet)
| otherwise
= (meth_id, emptyNameSet)
- is_inline (InlineSig _ name _ _) = name == idName sel_id
- is_inline other = False
-
meth_tvs' = take (length meth_tvs) all_tyvars'
poly_meth_bind = AbsBinds meth_tvs'
(map instToId meth_dicts)
[(meth_tvs', final_meth_id, local_meth_id)]
inlines
(lie_binds `andMonoBinds` meth_bind)
+
in
- returnM poly_meth_bind
+ -- Deal with specialisation pragmas
+ -- The sel_name is what appears in the pragma
+ tcExtendLocalValEnv2 [(sel_name, final_meth_id)] (
+ getLIE (tcSpecSigs spec_prags) `thenM` \ (spec_binds1, prag_lie) ->
+
+ -- The prag_lie for a SPECIALISE pragma will mention the function itself,
+ -- so we have to simplify them away right now lest they float outwards!
+ bindInstsOfLocalFuns prag_lie [final_meth_id] `thenM` \ spec_binds2 ->
+ returnM (spec_binds1 `andMonoBinds` spec_binds2)
+ ) `thenM` \ spec_binds ->
+
+ returnM (poly_meth_bind `andMonoBinds` spec_binds)
mkMethodBind :: InstOrigin
-> TcM (Maybe Inst, Id)
-- mkMethId instantiates the selector Id at the specified types
--- THe
mkMethId origin clas sel_id inst_tys
= let
(tyvars,rho) = tcSplitForAllTys (idType sel_id)