isClassOpSig, isPragSig,
placeHolderType
)
-import BasicTypes ( RecFlag(..), StrictnessMark(..) )
+import BasicTypes ( RecFlag(..) )
import RnHsSyn ( RenamedTyClDecl, RenamedSig,
RenamedClassOpSig, RenamedMonoBinds,
maybeGenericMatch
import RnEnv ( lookupSysName )
import TcHsSyn ( TcMonoBinds )
-import Inst ( Inst, InstOrigin(..), instToId, newDicts, tcInstClassOp )
+import Inst ( Inst, InstOrigin(..), instToId, newDicts, newMethod )
import TcEnv ( TyThingDetails(..),
- tcLookupClass, tcExtendTyVarEnv2,
- tcExtendTyVarEnv
+ tcLookupClass, tcExtendLocalValEnv2,
+ tcExtendTyVarEnv2, tcExtendTyVarEnv
)
-import TcBinds ( tcMonoBinds )
+import TcTyDecls ( tcMkDataCon )
+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,
mkTyVarTys, mkPredTys, mkClassPred, tcSplitSigmaTy, tcSplitFunTys,
- tcIsTyVarTy, tcSplitTyConApp_maybe
+ tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitForAllTys, tcSplitPhiTy,
+ getClassPredTys_maybe, mkPhiTy
)
import TcRnMonad
import Generics ( mkGenericRhs )
import Class ( classTyVars, classBigSig, classTyCon,
Class, ClassOpItem, DefMeth (..) )
import TyCon ( tyConGenInfo )
-import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
-import DataCon ( mkDataCon )
-import Id ( Id, idType, idName, setIdLocalExported, setInlinePragma )
+import Subst ( substTyWith )
+import MkId ( mkDictSelId, mkDefaultMethodId )
+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 )
+import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc, reportIfUnused )
import Outputable
import Var ( TyVar )
import CmdLineOpts
import UnicodeUtil ( stringToUtf8 )
import ErrUtils ( dumpIfSet )
-import Util ( count, lengthIs )
+import Util ( count, lengthIs, isSingleton )
import Maybes ( seqMaybe )
import Maybe ( isJust )
import FastString
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
mappM (tcClassSig clas tyvars mb_dm_env) op_sigs `thenM` \ sig_stuff ->
-- MAKE THE CLASS DETAILS
- lookupSysName class_name mkClassDataConOcc `thenM` \ datacon_name ->
- lookupSysName datacon_name mkWorkerOcc `thenM` \ datacon_wkr_name ->
+ lookupSysName class_name mkClassTyConOcc `thenM` \ tycon_name ->
+ lookupSysName class_name mkClassDataConOcc `thenM` \ datacon_name ->
mapM (lookupSysName class_name . mkSuperDictSelOcc)
[1..length context] `thenM` \ sc_sel_names ->
-- We number off the superclass selectors, 1, 2, 3 etc so that we
-- D_sc1, D_sc2
-- (We used to call them D_C, but now we can have two different
-- superclasses both called C!)
- lookupSysName class_name mkClassTyConOcc `thenM` \ tycon_name ->
let
(op_tys, op_items) = unzip sig_stuff
sc_tys = mkPredTys sc_theta
dict_component_tys = sc_tys ++ op_tys
sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names]
-
- dict_con = mkDataCon datacon_name
- [NotMarkedStrict | _ <- dict_component_tys]
- [{- No labelled fields -}]
- tyvars
- [{-No context-}]
- [{-No existential tyvars-}] [{-Or context-}]
- dict_component_tys
- (classTyCon clas)
- dict_con_id dict_wrap_id
-
- dict_con_id = mkDataConId datacon_wkr_name dict_con
- dict_wrap_id = mkDataConWrapId dict_con
in
+ tcMkDataCon datacon_name
+ [{- No strictness -}]
+ [{- No labelled fields -}]
+ tyvars [{-No context-}]
+ [{-No existential tyvars-}] [{-Or context-}]
+ dict_component_tys
+ (classTyCon clas) `thenM` \ dict_con ->
+
returnM (class_name, ClassDetails sc_theta sc_sel_ids op_items dict_con tycon_name)
\end{code}
in
newDicts origin theta `thenM` \ [this_dict] ->
- mkMethodBind origin clas inst_tys binds_in op_item `thenM` \ (dm_inst, meth_info) ->
+ mkMethodBind origin clas inst_tys binds_in op_item `thenM` \ (_, meth_info) ->
getLIE (tcMethodBind xtve clas_tyvars theta
[this_dict] prags meth_info) `thenM` \ (defm_bind, insts_needed) ->
checkSigTyVars clas_tyvars `thenM` \ clas_tyvars' ->
let
+ (_,dm_inst_id,_) = meth_info
full_bind = AbsBinds
clas_tyvars'
[instToId this_dict]
- [(clas_tyvars', local_dm_id, instToId dm_inst)]
+ [(clas_tyvars', local_dm_id, dm_inst_id)]
emptyNameSet -- No inlines (yet)
(dict_binds `andMonoBinds` defm_bind)
in
\begin{code}
type MethodSpec = (Id, -- Global selector Id
- TcSigInfo, -- Signature
+ Id, -- Local Id (class tyvars instantiated)
RenamedMonoBinds) -- Binding for the method
tcMethodBind
-> TcM TcMonoBinds
tcMethodBind xtve inst_tyvars inst_theta avail_insts prags
- (sel_id, meth_sig, meth_bind)
+ (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 ->
+
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
-> Class -> [TcType] -- Class and instance types
-> RenamedMonoBinds -- Method binding (pick the right one from in here)
-> ClassOpItem
- -> TcM (Inst, -- Method inst
+ -> TcM (Maybe Inst, -- Method inst
MethodSpec)
-- Find the binding for the specified method, or make
-- up a suitable default method if it isn't there
mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info)
- = getInstLoc origin `thenM` \ inst_loc ->
- tcInstClassOp inst_loc sel_id inst_tys `thenM` \ meth_inst ->
- -- Do not dump anything into the LIE
+ = mkMethId origin clas sel_id inst_tys `thenM` \ (mb_inst, meth_id) ->
let
- meth_id = instToId meth_inst
meth_name = idName meth_id
in
-- Figure out what method binding to use
Just user_bind -> returnM user_bind
Nothing -> mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs ->
returnM (FunMonoBind meth_name False -- Not infix decl
- [mkSimpleMatch [] rhs placeHolderType loc] loc)
+ [mkSimpleMatch [] rhs placeHolderType loc] loc)
) `thenM` \ meth_bind ->
- mkTcSig meth_id loc `thenM` \ meth_sig ->
-
- returnM (meth_inst, (sel_id, meth_sig, meth_bind))
-
+ returnM (mb_inst, (sel_id, meth_id, meth_bind))
+
+mkMethId :: InstOrigin -> Class
+ -> Id -> [TcType] -- Selector, and instance types
+ -> TcM (Maybe Inst, Id)
+
+-- mkMethId instantiates the selector Id at the specified types
+mkMethId origin clas sel_id inst_tys
+ = let
+ (tyvars,rho) = tcSplitForAllTys (idType sel_id)
+ rho_ty = ASSERT( length tyvars == length inst_tys )
+ substTyWith tyvars inst_tys rho
+ (preds,tau) = tcSplitPhiTy rho_ty
+ first_pred = head preds
+ in
+ -- The first predicate should be of form (C a b)
+ -- where C is the class in question
+ ASSERT( not (null preds) &&
+ case getClassPredTys_maybe first_pred of
+ { Just (clas1,tys) -> clas == clas1 ; Nothing -> False }
+ )
+ if isSingleton preds then
+ -- If it's the only one, make a 'method'
+ getInstLoc origin `thenM` \ inst_loc ->
+ newMethod inst_loc sel_id inst_tys preds tau `thenM` \ meth_inst ->
+ returnM (Just meth_inst, instToId meth_inst)
+ else
+ -- If it's not the only one we need to be careful
+ -- For example, given 'op' defined thus:
+ -- class Foo a where
+ -- op :: (?x :: String) => a -> a
+ -- (mkMethId op T) should return an Inst with type
+ -- (?x :: String) => T -> T
+ -- That is, the class-op's context is still there.
+ -- BUT: it can't be a Method any more, because it breaks
+ -- INVARIANT 2 of methods. (See the data decl for Inst.)
+ newUnique `thenM` \ uniq ->
+ getSrcLocM `thenM` \ loc ->
+ let
+ real_tau = mkPhiTy (tail preds) tau
+ meth_id = mkUserLocal (getOccName sel_id) uniq real_tau loc
+ in
+ returnM (Nothing, meth_id)
-- The user didn't supply a method binding,
-- so we have to make up a default binding
= -- No default method
-- Warn only if -fwarn-missing-methods
doptM Opt_WarnMissingMethods `thenM` \ warn ->
- warnTc (isInstDecl origin && warn)
+ warnTc (isInstDecl origin
+ && warn
+ && reportIfUnused (getOccName sel_id))
(omittedMethodWarn sel_id) `thenM_`
returnM error_rhs
where
projects / ghc-hetmet.git / blobdiff