#include "HsVersions.h"
import HsSyn
-import BasicTypes ( RecFlag(..) )
import RnHsSyn ( maybeGenericMatch, extractHsTyVars )
import RnExpr ( rnLExpr )
import RnEnv ( lookupTopBndrRn, lookupImportedName )
-
-import Inst ( Inst, InstOrigin(..), instToId, newDicts, newMethod )
-import TcEnv ( tcLookupLocatedClass, tcExtendLocalValEnv2,
- tcExtendTyVarEnv2,
+import Inst ( instToId, newDicts, newDictsAtLoc, newMethod, getOverlapFlag )
+import InstEnv ( mkLocalInstance )
+import TcEnv ( tcLookupLocatedClass,
+ tcExtendTyVarEnv, tcExtendIdEnv,
InstInfo(..), pprInstInfoDetails,
simpleInstInfoTyCon, simpleInstInfoTy,
InstBindings(..), newDFunName
)
-import TcBinds ( tcMonoBinds, tcSpecSigs )
-import TcHsType ( TcSigInfo(..), mkTcSig, tcHsKindedType, tcHsSigType )
-import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
+import TcBinds ( TcPragFun, tcMonoBinds, tcPrags, mkPragFun, TcSigInfo(..) )
+import TcHsType ( tcHsKindedType, tcHsSigType )
+import TcSimplify ( tcSimplifyCheck )
import TcUnify ( checkSigTyVars, sigCtxt )
-import TcMType ( tcInstTyVars, UserTypeCtxt( GenPatCtxt ) )
-import TcType ( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar,
+import TcMType ( tcSkolSigTyVars )
+import TcType ( Type, SkolemInfo(ClsSkol, InstSkol), UserTypeCtxt( GenPatCtxt ),
+ TcType, TcThetaType, TcTyVar, mkTyVarTys,
mkClassPred, tcSplitSigmaTy, tcSplitFunTys,
tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitForAllTys, tcSplitPhiTy,
getClassPredTys_maybe, mkPhiTy, mkTyVarTy
import Class ( classTyVars, classBigSig,
Class, ClassOpItem, DefMeth (..) )
import TyCon ( TyCon, tyConName, tyConHasGenerics )
-import Subst ( substTyWith )
+import Type ( substTyWith )
import MkId ( mkDefaultMethodId, mkDictFunId )
-import Id ( Id, idType, idName, mkUserLocal, setInlinePragma )
+import Id ( Id, idType, idName, mkUserLocal )
import Name ( Name, NamedThing(..) )
import NameEnv ( NameEnv, lookupNameEnv, mkNameEnv )
-import NameSet ( emptyNameSet, unitNameSet, nameSetToList )
+import NameSet ( nameSetToList )
import OccName ( reportIfUnused, mkDefaultMethodOcc )
import RdrName ( RdrName, mkDerivedRdrName )
import Outputable
-import Var ( TyVar )
import PrelNames ( genericTyConNames )
-import CmdLineOpts
-import UnicodeUtil ( stringToUtf8 )
+import DynFlags
import ErrUtils ( dumpIfSet_dyn )
import Util ( count, lengthIs, isSingleton, lengthExceeds )
import Unique ( Uniquable(..) )
import SrcLoc ( Located(..), srcSpanStart, unLoc, noLoc )
import Maybes ( seqMaybe, isJust, mapCatMaybes )
import List ( partition )
+import BasicTypes ( RecFlag(..), Boxity(..) )
import Bag
import FastString
\end{code}
= do { dm_env <- checkDefaultBinds clas op_names def_methods
; mappM (tcClassSig dm_env) op_sigs }
where
- op_sigs = [sig | sig@(L _ (Sig _ _)) <- sigs]
- op_names = [n | sig@(L _ (Sig (L _ n) _)) <- op_sigs]
+ op_sigs = [sig | sig@(L _ (TypeSig _ _)) <- sigs]
+ op_names = [n | sig@(L _ (TypeSig (L _ n) _)) <- op_sigs]
checkDefaultBinds :: Name -> [Name] -> LHsBinds Name -> TcM (NameEnv Bool)
= do dm_infos <- mapM (addLocM (checkDefaultBind clas ops)) (bagToList binds)
return (mkNameEnv dm_infos)
-checkDefaultBind clas ops (FunBind (L _ op) _ matches)
+checkDefaultBind clas ops (FunBind {fun_id = L _ op, fun_matches = MatchGroup matches _ })
= do { -- Check that the op is from this class
checkTc (op `elem` ops) (badMethodErr clas op)
-> LSig Name
-> TcM TcMethInfo
-tcClassSig dm_env (L loc (Sig (L _ op_name) op_hs_ty))
- = addSrcSpan loc $ do
+tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty))
+ = setSrcSpan loc $ do
{ op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
; let dm = case lookupNameEnv dm_env op_name of
Nothing -> NoDefMeth
tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
tcdMeths = default_binds}))
- = recoverM (returnM (emptyBag, [])) $
- addSrcSpan loc $
+ = recoverM (returnM (emptyLHsBinds, [])) $
+ setSrcSpan loc $
tcLookupLocatedClass class_name `thenM` \ clas ->
-- We make a separate binding for each default method.
-- default methods. Better to make separate AbsBinds for each
let
(tyvars, _, _, op_items) = classBigSig clas
- prags = filter (isPragSig.unLoc) sigs
- tc_dm = tcDefMeth clas tyvars default_binds prags
+ prag_fn = mkPragFun sigs
+ tc_dm = tcDefMeth clas tyvars default_binds prag_fn
dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items]
-- Generate code for polymorphic default methods only
mapAndUnzipM tc_dm dm_sel_ids `thenM` \ (defm_binds, dm_ids_s) ->
returnM (listToBag defm_binds, concat dm_ids_s)
-tcDefMeth clas tyvars binds_in prags sel_id
- = lookupTopBndrRn (mkDefMethRdrName sel_id) `thenM` \ dm_name ->
- tcInstTyVars ClsTv tyvars `thenM` \ (clas_tyvars, inst_tys, _) ->
- let
- 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
- origin = ClassDeclOrigin
- in
- mkMethodBind origin clas inst_tys
- binds_in (sel_id, DefMeth) `thenM` \ (_, meth_info) ->
- newDicts origin theta `thenM` \ [this_dict] ->
- getLIE (tcMethodBind xtve clas_tyvars theta
- [this_dict] prags meth_info) `thenM` \ (defm_bind, insts_needed) ->
+tcDefMeth clas tyvars binds_in prag_fn sel_id
+ = do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id)
+ ; let rigid_info = ClsSkol clas
+ clas_tyvars = tcSkolSigTyVars rigid_info tyvars
+ inst_tys = mkTyVarTys clas_tyvars
+ dm_ty = idType sel_id -- Same as dict selector!
+ theta = [mkClassPred clas inst_tys]
+ local_dm_id = mkDefaultMethodId dm_name dm_ty
+ origin = SigOrigin rigid_info
+
+ ; (_, meth_info) <- mkMethodBind origin clas inst_tys binds_in (sel_id, DefMeth)
+ ; [this_dict] <- newDicts origin theta
+ ; (defm_bind, insts_needed) <- getLIE (tcMethodBind clas_tyvars theta
+ [this_dict] prag_fn meth_info)
- addErrCtxt (defltMethCtxt clas) $
+ ; addErrCtxt (defltMethCtxt clas) $ do
-- Check the context
- tcSimplifyCheck
- (ptext SLIT("class") <+> ppr clas)
- clas_tyvars
- [this_dict]
- insts_needed `thenM` \ dict_binds ->
+ { dict_binds <- tcSimplifyCheck
+ (ptext SLIT("class") <+> ppr clas)
+ clas_tyvars
+ [this_dict]
+ insts_needed
-- Simplification can do unification
- checkSigTyVars clas_tyvars `thenM` \ clas_tyvars' ->
+ ; checkSigTyVars clas_tyvars
- let
- (_,dm_inst_id,_) = meth_info
- full_bind = AbsBinds
- clas_tyvars'
- [instToId this_dict]
- [(clas_tyvars', local_dm_id, dm_inst_id)]
- emptyNameSet -- No inlines (yet)
- (dict_binds `unionBags` defm_bind)
- in
- returnM (noLoc full_bind, [local_dm_id])
+ -- Inline pragmas
+ -- We'll have an inline pragma on the local binding, made by tcMethodBind
+ -- but that's not enough; we want one on the global default method too
+ -- Specialisations, on the other hand, belong on the thing inside only, I think
+ ; let (_,dm_inst_id,_) = meth_info
+ sel_name = idName sel_id
+ inline_prags = filter isInlineLSig (prag_fn sel_name)
+ ; prags <- tcPrags dm_inst_id inline_prags
+
+ ; let full_bind = AbsBinds clas_tyvars
+ [instToId this_dict]
+ [(clas_tyvars, local_dm_id, dm_inst_id, prags)]
+ (dict_binds `unionBags` defm_bind)
+ ; returnM (noLoc full_bind, [local_dm_id]) }}
mkDefMethRdrName :: Id -> RdrName
mkDefMethRdrName sel_id = mkDerivedRdrName (idName sel_id) mkDefaultMethodOcc
LHsBind Name) -- Binding for the method
tcMethodBind
- :: [(TyVar,TcTyVar)] -- Bindings for type environment
- -> [TcTyVar] -- Instantiated type variables for the
+ :: [TcTyVar] -- Skolemised type variables for the
-- enclosing class/instance decl.
-- They'll be signature tyvars, and we
-- want to check that they don't get bound
+ -- Also they are scoped, so we bring them into scope
-- Always equal the range of the type envt
-> TcThetaType -- Available theta; it's just used for the error message
-> [Inst] -- Available from context, used to simplify constraints
-- from the method body
- -> [LSig Name] -- Pragmas (e.g. inline pragmas)
+ -> TcPragFun -- Pragmas (e.g. inline pragmas)
-> MethodSpec -- Details of this method
-> TcM (LHsBinds Id)
-tcMethodBind xtve inst_tyvars inst_theta avail_insts prags
+tcMethodBind inst_tyvars inst_theta avail_insts prag_fn
(sel_id, meth_id, meth_bind)
- = recoverM (returnM emptyBag) $
+ = recoverM (returnM emptyLHsBinds) $
-- If anything fails, recover returning no bindings.
-- This is particularly useful when checking the default-method binding of
-- a class decl. If we don't recover, we don't add the default method to
-- 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 (unitBag meth_bind) [meth_sig] NonRecursive
- ) `thenM` \ ((meth_bind,_), meth_lie) ->
+
+ let meth_sig = noLoc (TypeSig (noLoc (idName meth_id)) (noLoc bogus_ty))
+ bogus_ty = HsTupleTy Boxed [] -- *Only* used to extract scoped type
+ -- variables... and there aren't any
+ lookup_sig name = ASSERT( name == idName meth_id )
+ Just meth_sig
+ in
+ tcExtendTyVarEnv inst_tyvars (
+ tcExtendIdEnv [meth_id] $ -- In scope for tcInstSig
+ addErrCtxt (methodCtxt sel_id) $
+ getLIE $
+ tcMonoBinds [meth_bind] lookup_sig Recursive
+ ) `thenM` \ ((meth_bind, mono_bind_infos), 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
--
-- We do this for each method independently to localise error messages
- let
- TySigInfo { sig_poly_id = meth_id, sig_tvs = meth_tvs,
- sig_theta = meth_theta, sig_mono_id = local_meth_id } = meth_sig
- in
- addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
- newDicts SignatureOrigin meth_theta `thenM` \ meth_dicts ->
- let
+ let
+ [(_, Just sig, local_meth_id)] = mono_bind_infos
+ in
+
+ addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
+ newDictsAtLoc (sig_loc sig) (sig_theta sig) `thenM` \ meth_dicts ->
+ let
+ meth_tvs = sig_tvs sig
all_tyvars = meth_tvs ++ inst_tyvars
all_insts = avail_insts ++ meth_dicts
- in
- tcSimplifyCheck
+ sel_name = idName sel_id
+ in
+ tcSimplifyCheck
(ptext SLIT("class or instance method") <+> quotes (ppr sel_id))
all_tyvars all_insts meth_lie `thenM` \ lie_binds ->
- checkSigTyVars all_tyvars `thenM` \ all_tyvars' ->
+ checkSigTyVars all_tyvars `thenM_`
- let
- sel_name = idName sel_id
- inline_prags = [ (is_inl, phase)
- | L _ (InlineSig is_inl (L _ name) phase) <- prags,
- name == sel_name ]
- spec_prags = [ prag
- | prag@(L _ (SpecSig (L _ name) _)) <- prags,
- name == sel_name]
-
- -- Attach inline pragmas as appropriate
- (final_meth_id, inlines)
- | ((is_inline, phase) : _) <- inline_prags
- = (meth_id `setInlinePragma` phase,
- if is_inline then unitNameSet (idName meth_id) else emptyNameSet)
- | otherwise
- = (meth_id, emptyNameSet)
-
- meth_tvs' = take (length meth_tvs) all_tyvars'
- poly_meth_bind = noLoc $ AbsBinds meth_tvs'
+ tcPrags meth_id (prag_fn sel_name) `thenM` \ prags ->
+ let
+ poly_meth_bind = noLoc $ AbsBinds meth_tvs
(map instToId meth_dicts)
- [(meth_tvs', final_meth_id, local_meth_id)]
- inlines
+ [(meth_tvs, meth_id, local_meth_id, prags)]
(lie_binds `unionBags` meth_bind)
-
- in
- -- 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 `unionBags` spec_binds2)
- ) `thenM` \ spec_binds ->
-
- returnM (poly_meth_bind `consBag` spec_binds)
+ in
+ returnM (unitBag poly_meth_bind)
mkMethodBind :: InstOrigin
Nothing ->
mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs ->
-- Not infix decl
- returnM (noLoc $ FunBind (noLoc meth_name) False
- [mkSimpleMatch [] rhs placeHolderType])
+ returnM (noLoc $ mkFunBind (noLoc meth_name) [mkSimpleMatch [] rhs])
) `thenM` \ meth_bind ->
returnM (mb_inst, (sel_id, meth_id, meth_bind))
)
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 ->
+ getInstLoc origin `thenM` \ inst_loc ->
+ newMethod inst_loc sel_id inst_tys `thenM` \ meth_inst ->
returnM (Just meth_inst, instToId meth_inst)
else
-- If it's not the only one we need to be careful
(omittedMethodWarn sel_id) `thenM_`
returnM error_rhs
where
- error_rhs = noLoc $ HsLam (mkSimpleMatch wild_pats simple_rhs placeHolderType)
+ error_rhs = noLoc $ HsLam (mkMatchGroup [mkSimpleMatch wild_pats simple_rhs])
simple_rhs = nlHsApp (nlHsVar (getName nO_METHOD_BINDING_ERROR_ID))
- (nlHsLit (HsStringPrim (mkFastString (stringToUtf8 error_msg))))
+ (nlHsLit (HsStringPrim (mkFastString error_msg)))
error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
-- When the type is of form t1 -> t2 -> t3
-- Need two splits because the selector can have a type like
-- forall a. Foo a => forall b. Eq b => ...
(arg_tys, _) = tcSplitFunTys tau2
- wild_pats = [wildPat | ty <- arg_tys]
+ wild_pats = [nlWildPat | ty <- arg_tys]
mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
= -- A generic default method
other -> Nothing
other -> Nothing
-isInstDecl InstanceDeclOrigin = True
-isInstDecl ClassDeclOrigin = False
+isInstDecl (SigOrigin (InstSkol _)) = True
+isInstDecl (SigOrigin (ClsSkol _)) = False
\end{code}
find_bind sel_name meth_name binds
= foldlBag seqMaybe Nothing (mapBag f binds)
where
- f (L loc1 (FunBind (L loc2 op_name) fix matches)) | op_name == sel_name
- = Just (L loc1 (FunBind (L loc2 meth_name) fix matches))
+ f (L loc1 bind@(FunBind { fun_id = L loc2 op_name })) | op_name == sel_name
+ = Just (L loc1 (bind { fun_id = L loc2 meth_name }))
f _other = Nothing
\end{code}
-- them in finite map indexed by the type parameter in the definition.
getGenericBinds binds = concat (map getGenericBind (bagToList binds))
-getGenericBind (L loc (FunBind id infixop matches))
+getGenericBind (L loc bind@(FunBind { fun_matches = MatchGroup matches ty }))
= groupWith wrap (mapCatMaybes maybeGenericMatch matches)
where
- wrap ms = L loc (FunBind id infixop ms)
+ wrap ms = L loc (bind { fun_matches = MatchGroup ms ty })
getGenericBind _
= []
-- Make the dictionary function.
getSrcSpanM `thenM` \ span ->
+ getOverlapFlag `thenM` \ overlap_flag ->
newDFunName clas [inst_ty] (srcSpanStart span) `thenM` \ dfun_name ->
let
inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
+ ispec = mkLocalInstance dfun_id overlap_flag
in
-
- returnM (InstInfo { iDFunId = dfun_id, iBinds = VanillaInst binds [] })
+ returnM (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] })
\end{code}
ptext SLIT("All the type patterns for a generic type constructor must be identical")
]
where
- ppr_inst_ty (tc,inst) = ppr tc <+> ppr (simpleInstInfoTy inst)
+ ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
mixedGenericErr op
= ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
projects / ghc-hetmet.git / blobdiff