import Class
import Var
import CoreUnfold ( mkDFunUnfolding )
+import CoreSyn ( Expr(Var) )
import Id
import MkId
import Name
df :: forall a. C a => C [a]
{-# NOINLINE df DFun[ $cop_list ] #-}
- df = /\a. \d. MkD ($cop_list a d)
+ df = /\a. \d. MkC ($cop_list a d)
- $cop_list :: forall a. C a => a -> a
+ $cop_list :: forall a. C a => [a] -> [a]
$cop_list = <blah>
-The "constructor" MkD expands to a cast, as does the class-op selector.
+The "constructor" MkC expands to a cast, as does the class-op selector.
The RULE works just like for multi-field dictionaries:
- * (df a d) returns (Just (MkD,..,[$cop_list a d]))
+
+ * (df a d) returns (Just (MkC,..,[$cop_list a d]))
to exprIsConApp_Maybe
* The RULE for op picks the right result
is otherwise used only when we hit a case expression which will have
a real data constructor in it.
-The biggest reason for doing it this way, apart form uniformity, is
+The biggest reason for doing it this way, apart from uniformity, is
that we want to be very careful when we have
instance C a => C [a] where
{-# INLINE op #-}
op = ...
-then we'll get an INLINE pragma on $cop_list. The danger is that
-we'll get something like
- foo = /\a.\d. $cop_list a d
+then we'll get an INLINE pragma on $cop_list but it's important that
+$cop_list only inlines when it's applied to *two* arguments (the
+dictionary and the list argument
+
+The danger is that we'll get something like
+ op_list :: C a => [a] -> [a]
+ op_list = /\a.\d. $cop_list a d
and then we'll eta expand, and then we'll inline TOO EARLY. This happened in
-Trac #3772 and I spent far too long fiddling arond trying to fix it.
+Trac #3772 and I spent far too long fiddling around trying to fix it.
Look at the test for Trac #3772.
+ (Note: re-reading the above, I can't see how using the
+ uniform story solves the problem.)
+
Note [Subtle interaction of recursion and overlap]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this
-- round)
-- (1) Do class and family instance declarations
- ; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls }
+ ; idx_tycons <- mapAndRecoverM (tcFamInstDecl TopLevel) $
+ filter (isFamInstDecl . unLoc) tycl_decls
; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls
- ; idx_tycons <- mapAndRecoverM tcIdxTyInstDeclTL idxty_decls
; let { (local_info,
at_tycons_s) = unzip local_info_tycons
; at_idx_tycons = concat at_tycons_s ++ idx_tycons
; clas_decls = filter (isClassDecl.unLoc) tycl_decls
; implicit_things = concatMap implicitTyThings at_idx_tycons
- ; aux_binds = mkAuxBinds at_idx_tycons
+ ; aux_binds = mkRecSelBinds at_idx_tycons
}
-- (2) Add the tycons of indexed types and their implicit
-- Next, construct the instance environment so far, consisting
-- of
- -- a) local instance decls
- -- b) generic instances
- -- c) local family instance decls
+ -- (a) local instance decls
+ -- (b) generic instances
+ -- (c) local family instance decls
; addInsts local_info $
addInsts generic_inst_info $
addFamInsts at_idx_tycons $ do {
generic_inst_info ++ deriv_inst_info ++ local_info,
aux_binds `plusHsValBinds` deriv_binds)
}}}
- where
- -- Make sure that toplevel type instance are not for associated types.
- -- !!!TODO: Need to perform this check for the TyThing of type functions,
- -- too.
- tcIdxTyInstDeclTL ldecl@(L loc decl) =
- do { tything <- tcFamInstDecl ldecl
- ; setSrcSpan loc $
- when (isAssocFamily tything) $
- addErr $ assocInClassErr (tcdName decl)
- ; return tything
- }
- isAssocFamily (ATyCon tycon) =
- case tyConFamInst_maybe tycon of
- Nothing -> panic "isAssocFamily: no family?!?"
- Just (fam, _) -> isTyConAssoc fam
- isAssocFamily _ = panic "isAssocFamily: no tycon?!?"
-
-assocInClassErr :: Name -> SDoc
-assocInClassErr name =
- ptext (sLit "Associated type") <+> quotes (ppr name) <+>
- ptext (sLit "must be inside a class instance")
addInsts :: [InstInfo Name] -> TcM a -> TcM a
addInsts infos thing_inside
-- Next, process any associated types.
; idx_tycons <- recoverM (return []) $
- do { idx_tycons <- checkNoErrs $ mapAndRecoverM tcFamInstDecl ats
+ do { idx_tycons <- checkNoErrs $
+ mapAndRecoverM (tcFamInstDecl NotTopLevel) ats
; checkValidAndMissingATs clas (tyvars, inst_tys)
(zip ats idx_tycons)
; return idx_tycons }
\begin{code}
tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
- -> TcM (LHsBinds Id, TcLclEnv)
+ -> TcM (LHsBinds Id)
-- (a) From each class declaration,
-- generate any default-method bindings
-- (b) From each instance decl
tcInstDecls2 tycl_decls inst_decls
= do { -- (a) Default methods from class decls
let class_decls = filter (isClassDecl . unLoc) tycl_decls
- ; (dm_ids_s, dm_binds_s) <- mapAndUnzipM tcClassDecl2 class_decls
+ ; dm_binds_s <- mapM tcClassDecl2 class_decls
+ ; let dm_binds = unionManyBags dm_binds_s
- ; tcExtendIdEnv (concat dm_ids_s) $ do
-
-- (b) instance declarations
- { inst_binds_s <- mapM tcInstDecl2 inst_decls
+ ; let dm_ids = collectHsBindsBinders dm_binds
+ -- Add the default method Ids (again)
+ -- See Note [Default methods and instances]
+ ; inst_binds_s <- tcExtendIdEnv dm_ids $
+ mapM tcInstDecl2 inst_decls
-- Done
- ; let binds = unionManyBags dm_binds_s `unionBags`
- unionManyBags inst_binds_s
- ; tcl_env <- getLclEnv -- Default method Ids in here
- ; return (binds, tcl_env) } }
+ ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
loc = getSrcSpan dfun_id
\end{code}
+See Note [Default methods and instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The default method Ids are already in the type environment (see Note
+[Default method Ids and Template Haskell] in TcTyClsDcls), BUT they
+don't have their InlinePragmas yet. Usually that would not matter,
+because the simplifier propagates information from binding site to
+use. But, unusually, when compiling instance decls we *copy* the
+INLINE pragma from the default method to the method for that
+particular operation (see Note [INLINE and default methods] below).
+
+So right here in tcInstDecl2 we must re-extend the type envt with
+the default method Ids replete with their INLINE pragmas. Urk.
\begin{code}
tc_inst_decl2 :: Id -> InstBindings Name -> TcM (LHsBinds Id)
-- Ordinary instances
tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
- = do { let rigid_info = InstSkol
- inst_ty = idType dfun_id
- loc = getSrcSpan dfun_id
+ = do { let rigid_info = InstSkol
+ inst_ty = idType dfun_id
+ loc = getSrcSpan dfun_id
-- Instantiate the instance decl with skolem constants
; (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty
; let dict_constr = classDataCon clas
this_dict_id = instToId this_dict
dict_bind = mkVarBind this_dict_id dict_rhs
- dict_rhs = foldl mk_app inst_constr (sc_ids ++ meth_ids)
+ dict_rhs = foldl mk_app inst_constr sc_meth_ids
+ sc_meth_ids = sc_ids ++ meth_ids
inst_constr = L loc $ wrapId (mkWpTyApps inst_tys')
(dataConWrapId dict_constr)
-- We don't produce a binding for the dict_constr; instead we
-- See Note [ClassOp/DFun selection]
-- See also note [Single-method classes]
dfun_id_w_fun = dfun_id
- `setIdUnfolding` mkDFunUnfolding dict_constr (sc_ids ++ meth_ids)
+ `setIdUnfolding` mkDFunUnfolding inst_ty (map Var sc_meth_ids)
`setInlinePragma` dfunInlinePragma
main_bind = AbsBinds
= add_meth_ctxt rn_bind $
do { (meth_id1, spec_prags) <- tcPrags NonRecursive False True
meth_id (prag_fn sel_name)
- ; tcInstanceMethodBody (instLoc this_dict)
+ ; bind <- tcInstanceMethodBody (instLoc this_dict)
tyvars dfun_dicts
([this_dict], this_dict_bind)
meth_id1 local_meth_id
meth_sig_fn
(SpecPrags (spec_inst_prags ++ spec_prags))
- rn_bind }
+ rn_bind
+ ; return (meth_id1, bind) }
--------------
tc_default :: DefMeth -> TcM (Id, LHsBind Id)
projects / ghc-hetmet.git / blobdiff