getOverlapFlag, tcExtendLocalInstEnv )
import InstEnv ( mkLocalInstance, instanceDFunId )
import FamInst ( tcExtendLocalFamInstEnv )
-import FamInstEnv ( extractFamInsts )
+import FamInstEnv ( mkLocalFamInst )
import TcDeriv ( tcDeriving )
import TcEnv ( InstInfo(..), InstBindings(..),
newDFunName, tcExtendIdEnv, tcExtendGlobalEnv
substTys, emptyTvSubst, extendTvSubst )
import Coercion ( mkSymCoercion )
import TyCon ( TyCon, tyConName, newTyConCo_maybe, tyConTyVars,
- isTyConAssoc, tyConFamInst_maybe,
+ isTyConAssoc, tyConFamInst_maybe, tyConDataCons,
assocTyConArgPoss_maybe )
import DataCon ( classDataCon, dataConInstArgTys )
import Class ( Class, classTyCon, classBigSig, classATs )
tcInstDecls1 -- Deal with both source-code and imported instance decls
:: [LTyClDecl Name] -- For deriving stuff
-> [LInstDecl Name] -- Source code instance decls
+ -> [LDerivDecl Name] -- Source code stand-alone deriving decls
-> TcM (TcGblEnv, -- The full inst env
[InstInfo], -- Source-code instance decls to process;
-- contains all dfuns for this module
HsValBinds Name) -- Supporting bindings for derived instances
-tcInstDecls1 tycl_decls inst_decls
+tcInstDecls1 tycl_decls inst_decls deriv_decls
= checkNoErrs $
do { -- Stop if addInstInfos etc discovers any errors
-- (they recover, so that we get more than one error each
-- (4) Compute instances from "deriving" clauses;
-- This stuff computes a context for the derived instance
-- decl, so it needs to know about all the instances possible
- ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls
+ ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls deriv_decls
; addInsts deriv_inst_info $ do {
; gbl_env <- getGblEnv
addFamInsts :: [TyThing] -> TcM a -> TcM a
addFamInsts tycons thing_inside
- = tcExtendLocalFamInstEnv (extractFamInsts tycons) thing_inside
+ = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
+ where
+ mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
+ mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts"
+ (ppr tything)
\end{code}
\begin{code}
-- Returns a binding for the dfun
------------------------
--- Derived newtype instances
+-- Derived newtype instances; surprisingly tricky!
--
-- In the case of a newtype, things are rather easy
-- class Show a => Foo a b where ...
-- inst_head_ty is a PredType
; inst_loc <- getInstLoc origin
- ; (rep_dict_id : sc_dict_ids, wrap_fn)
+ ; (rep_dict_id : sc_dict_ids, wrap_fn, sc_binds)
<- make_wrapper inst_loc tvs theta mb_preds
-- Here, we are relying on the order of dictionary
-- arguments built by NewTypeDerived in TcDeriv;
-- namely, that the rep_dict_id comes first
; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty
- the_coercion = make_coercion cls cls_inst_tys
- coerced_rep_dict = mkHsCoerce the_coercion (HsVar rep_dict_id)
+ cls_tycon = classTyCon cls
+ the_coercion = make_coercion cls_tycon cls_inst_tys
+ coerced_rep_dict = mkHsWrap the_coercion (HsVar rep_dict_id)
- ; body <- make_body cls cls_inst_tys inst_head_ty sc_dict_ids coerced_rep_dict
+ ; body <- make_body cls_tycon cls_inst_tys sc_dict_ids coerced_rep_dict
- ; return (unitBag (noLoc $ VarBind dfun_id $ noLoc $ mkHsCoerce wrap_fn body)) }
+ ; return (sc_binds `snocBag` (noLoc $ VarBind dfun_id $ noLoc $ mkHsWrap wrap_fn body)) }
where
-----------------------
make_wrapper inst_loc tvs theta (Just preds) -- Case (a)
= ASSERT( null tvs && null theta )
do { dicts <- newDictBndrs inst_loc preds
- ; extendLIEs dicts
- ; return (map instToId dicts, idCoercion) }
+ ; sc_binds <- addErrCtxt superClassCtxt (tcSimplifySuperClasses [] [] dicts)
+ -- Use tcSimplifySuperClasses to avoid creating loops, for the
+ -- same reason as Note [SUPERCLASS-LOOP 1] in TcSimplify
+ ; return (map instToId dicts, idHsWrapper, sc_binds) }
+
make_wrapper inst_loc tvs theta Nothing -- Case (b)
= do { dicts <- newDictBndrs inst_loc theta
; let dict_ids = map instToId dicts
- ; return (dict_ids, mkCoTyLams tvs <.> mkCoLams dict_ids) }
+ ; return (dict_ids, mkWpTyLams tvs <.> mkWpLams dict_ids, emptyBag) }
-----------------------
-- make_coercion
-- So we just replace T with CoT, and insert a 'sym'
-- NB: we know that k will be >= arity of CoT, because the latter fully eta-reduced
- make_coercion cls cls_inst_tys
+ make_coercion cls_tycon cls_inst_tys
| Just (all_tys_but_last, last_ty) <- snocView cls_inst_tys
, (tycon, tc_args) <- tcSplitTyConApp last_ty -- Should not fail
, Just co_con <- newTyConCo_maybe tycon
, let co = mkSymCoercion (mkTyConApp co_con tc_args)
- = ExprCoFn (mkTyConApp cls_tycon (all_tys_but_last ++ [co]))
+ = WpCo (mkTyConApp cls_tycon (all_tys_but_last ++ [co]))
| otherwise -- The newtype is transparent; no need for a cast
- = idCoercion
- where
- cls_tycon = classTyCon cls
+ = idHsWrapper
-----------------------
-- make_body
-- (a) no superclasses; then we can just use the coerced dict
-- (b) one or more superclasses; then new need to do the unpack/repack
- make_body cls cls_inst_tys inst_head_ty sc_dict_ids coerced_rep_dict
+ make_body cls_tycon cls_inst_tys sc_dict_ids coerced_rep_dict
| null sc_dict_ids -- Case (a)
= return coerced_rep_dict
| otherwise -- Case (b)
pat_dicts = dummy_sc_dict_ids,
pat_binds = emptyLHsBinds,
pat_args = PrefixCon (map nlVarPat op_ids),
- pat_ty = inst_head_ty}
+ pat_ty = pat_ty}
the_match = mkSimpleMatch [noLoc the_pat] the_rhs
the_rhs = mkHsConApp cls_data_con cls_inst_tys $
map HsVar (sc_dict_ids ++ op_ids)
+ -- Warning: this HsCase scrutinises a value with a PredTy, which is
+ -- never otherwise seen in Haskell source code. It'd be
+ -- nicer to generate Core directly!
; return (HsCase (noLoc coerced_rep_dict) $
- MatchGroup [the_match] (mkFunTy inst_head_ty inst_head_ty)) }
+ MatchGroup [the_match] (mkFunTy pat_ty pat_ty)) }
where
- cls_data_con = classDataCon cls
+ pat_ty = mkTyConApp cls_tycon cls_inst_tys
+ cls_data_con = head (tyConDataCons cls_tycon)
cls_arg_tys = dataConInstArgTys cls_data_con cls_inst_tys
op_tys = dropList sc_dict_ids cls_arg_tys
projects / ghc-hetmet.git / blobdiff