checkValidInstHead )
import TcType ( TcType, mkClassPred, tcSplitSigmaTy,
tcSplitDFunHead, SkolemInfo(InstSkol),
+ tcSplitTyConApp,
tcSplitDFunTy, mkFunTy )
import Inst ( newDictBndr, newDictBndrs, instToId, showLIE,
getOverlapFlag, tcExtendLocalInstEnv )
import InstEnv ( mkLocalInstance, instanceDFunId )
+import FamInst ( tcExtendLocalFamInstEnv )
+import FamInstEnv ( mkLocalFamInst )
import TcDeriv ( tcDeriving )
import TcEnv ( InstInfo(..), InstBindings(..),
newDFunName, tcExtendIdEnv, tcExtendGlobalEnv
import TcUnify ( checkSigTyVars )
import TcSimplify ( tcSimplifySuperClasses )
import Type ( zipOpenTvSubst, substTheta, mkTyConApp, mkTyVarTy,
- splitFunTys, TyThing(ATyCon), isTyVarTy, tcEqType,
+ TyThing(ATyCon), isTyVarTy, tcEqType,
substTys, emptyTvSubst, extendTvSubst )
import Coercion ( mkSymCoercion )
-import TyCon ( TyCon, tyConName, newTyConCo, tyConTyVars,
- isTyConAssoc, tyConFamInst_maybe,
+import TyCon ( TyCon, tyConName, newTyConCo_maybe, tyConTyVars,
+ isTyConAssoc, tyConFamInst_maybe, tyConDataCons,
assocTyConArgPoss_maybe )
-import DataCon ( classDataCon, dataConTyCon, dataConInstArgTys )
-import Class ( Class, classBigSig, classATs )
-import Var ( TyVar, Id, idName, idType, tyVarKind, tyVarName )
-import VarEnv ( rnBndrs2, mkRnEnv2, emptyInScopeSet )
-import Id ( mkSysLocal )
-import UniqSupply ( uniqsFromSupply, splitUniqSupply )
+import DataCon ( classDataCon, dataConInstArgTys )
+import Class ( Class, classTyCon, classBigSig, classATs )
+import Var ( TyVar, Id, idName, idType, tyVarName )
import MkId ( mkDictFunId )
import Name ( Name, getSrcLoc, nameOccName )
import NameSet ( addListToNameSet, emptyNameSet, minusNameSet,
nameSetToList )
-import Maybe ( isNothing, fromJust, catMaybes )
+import Maybe ( fromJust, catMaybes )
import Monad ( when )
import List ( find )
import DynFlags ( DynFlag(Opt_WarnMissingMethods) )
import SrcLoc ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart,
getLoc)
import ListSetOps ( minusList )
+import Util ( snocView, dropList )
import Outputable
import Bag
import BasicTypes ( Activation( AlwaysActive ), InlineSpec(..) )
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
-- types
; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
; local_info_tycons <- mappM tcLocalInstDecl1 inst_decls
- ; idxty_info_tycons <- mappM tcIdxTyInstDeclTL idxty_decls
+ ; idx_tycons <- mappM tcIdxTyInstDeclTL idxty_decls
; let { (local_infos,
- local_tycons) = unzip local_info_tycons
- ; (idxty_infos,
- idxty_tycons) = unzip idxty_info_tycons
- ; local_idxty_info = concat local_infos ++ catMaybes idxty_infos
- ; local_idxty_tycon = concat local_tycons ++
- catMaybes idxty_tycons
- ; clas_decls = filter (isClassDecl.unLoc) tycl_decls
- ; implicit_things = concatMap implicitTyThings local_idxty_tycon
+ at_tycons) = unzip local_info_tycons
+ ; local_info = concat local_infos
+ ; at_idx_tycon = concat at_tycons ++ catMaybes idx_tycons
+ ; clas_decls = filter (isClassDecl.unLoc) tycl_decls
+ ; implicit_things = concatMap implicitTyThings at_idx_tycon
}
- -- (2) Add the tycons of associated types and their implicit
+ -- (2) Add the tycons of indexed types and their implicit
-- tythings to the global environment
- ; tcExtendGlobalEnv (local_idxty_tycon ++ implicit_things) $ do {
+ ; tcExtendGlobalEnv (at_idx_tycon ++ implicit_things) $ do {
-- (3) Instances from generic class declarations
; generic_inst_info <- getGenericInstances clas_decls
-- of
-- a) local instance decls
-- b) generic instances
- ; addInsts local_idxty_info $ do {
- ; addInsts generic_inst_info $ do {
+ -- c) local family instance decls
+ ; addInsts local_info $ do {
+ ; addInsts generic_inst_info $ do {
+ ; addFamInsts at_idx_tycon $ do {
-- (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
; returnM (gbl_env,
- generic_inst_info ++ deriv_inst_info ++ local_idxty_info,
+ generic_inst_info ++ deriv_inst_info ++ local_info,
deriv_binds)
- }}}}}
+ }}}}}}
where
-- Make sure that toplevel type instance are not for associated types.
- -- !!!TODO: Need to perform this check for the InstInfo structures of type
- -- functions, too.
+ -- !!!TODO: Need to perform this check for the TyThing of type functions,
+ -- too.
tcIdxTyInstDeclTL ldecl@(L loc decl) =
- do { (info, tything) <- tcIdxTyInstDecl ldecl
+ do { tything <- tcIdxTyInstDecl ldecl
; setSrcSpan loc $
when (isAssocFamily tything) $
addErr $ assocInClassErr (tcdName decl)
- ; return (info, tything)
+ ; return tything
}
isAssocFamily (Just (ATyCon tycon)) =
case tyConFamInst_maybe tycon of
addInsts :: [InstInfo] -> TcM a -> TcM a
addInsts infos thing_inside
= tcExtendLocalInstEnv (map iSpec infos) thing_inside
+
+addFamInsts :: [TyThing] -> TcM a -> TcM a
+addFamInsts 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}
; let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
-- Next, process any associated types.
- ; idxty_info_tycons <- mappM tcIdxTyInstDecl ats
+ ; idx_tycons <- mappM tcIdxTyInstDecl ats
-- Now, check the validity of the instance.
; (clas, inst_tys) <- checkValidInstHead tau
; checkValidInstance tyvars theta clas inst_tys
; checkValidAndMissingATs clas (tyvars, inst_tys)
- (zip ats idxty_info_tycons)
+ (zip ats idx_tycons)
-- Finally, construct the Core representation of the instance.
-- (This no longer includes the associated types.)
; overlap_flag <- getOverlapFlag
; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys
ispec = mkLocalInstance dfun overlap_flag
- (idxty_infos,
- idxty_tycons) = unzip idxty_info_tycons
; return ([InstInfo { iSpec = ispec,
- iBinds = VanillaInst binds uprags }] ++
- catMaybes idxty_infos,
- catMaybes idxty_tycons)
+ iBinds = VanillaInst binds uprags }],
+ catMaybes idx_tycons)
}
where
-- We pass in the source form and the type checked form of the ATs. We
checkValidAndMissingATs :: Class
-> ([TyVar], [TcType]) -- instance types
-> [(LTyClDecl Name, -- source form of AT
- (Maybe InstInfo, -- Core form for type
- Maybe TyThing))] -- Core form for data
+ Maybe TyThing)] -- Core form of AT
-> TcM ()
checkValidAndMissingATs clas inst_tys ats
= do { -- Issue a warning for each class AT that is not defined in this
; mapM_ (checkIndexes clas inst_tys) ats
}
- checkIndexes _ _ (hsAT, (Nothing, Nothing)) =
+ checkIndexes _ _ (hsAT, Nothing) =
return () -- skip, we already had an error here
- checkIndexes clas inst_tys (hsAT, (Just _ , Nothing )) =
- panic "do impl for AT syns" -- !!!TODO: also call checkIndexes'
- checkIndexes clas inst_tys (hsAT, (Nothing , Just (ATyCon tycon))) =
+ checkIndexes clas inst_tys (hsAT, Just (ATyCon tycon)) =
+-- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
checkIndexes' clas inst_tys hsAT
(tyConTyVars tycon,
snd . fromJust . tyConFamInst_maybe $ tycon)
-- Returns a binding for the dfun
------------------------
--- Derived newtype instances
---
--- We need to make a copy of the dictionary we are deriving from
--- because we may need to change some of the superclass dictionaries
--- see Note [Newtype deriving superclasses] in TcDeriv.lhs
+-- Derived newtype instances; surprisingly tricky!
--
-- In the case of a newtype, things are rather easy
-- class Show a => Foo a b where ...
-- newtype T a = MkT (Tree [a]) deriving( Foo Int )
-- The newtype gives an FC axiom looking like
-- axiom CoT a :: T a :=: Tree [a]
+-- (see Note [Newtype coercions] in TyCon for this unusual form of axiom)
--
--- So all need is to generate a binding looking like
+-- So all need is to generate a binding looking like:
-- dfunFooT :: forall a. (Foo Int (Tree [a], Show (T a)) => Foo Int (T a)
-- dfunFooT = /\a. \(ds:Show (T a)) (df:Foo (Tree [a])).
-- case df `cast` (Foo Int (sym (CoT a))) of
-- Foo _ op1 .. opn -> Foo ds op1 .. opn
+--
+-- If there are no superclasses, matters are simpler, because we don't need the case
+-- see Note [Newtype deriving superclasses] in TcDeriv.lhs
-tcInstDecl2 (InstInfo { iSpec = ispec,
- iBinds = NewTypeDerived tycon rep_tys })
+tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds })
= do { let dfun_id = instanceDFunId ispec
rigid_info = InstSkol dfun_id
origin = SigOrigin rigid_info
inst_ty = idType dfun_id
+ ; (tvs, theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
+ -- inst_head_ty is a PredType
+
; inst_loc <- getInstLoc origin
- ; (tvs, theta, inst_head) <- tcSkolSigType rigid_info inst_ty
- ; dicts <- newDictBndrs inst_loc theta
- ; uniqs <- newUniqueSupply
- ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head
- ; this_dict <- newDictBndr inst_loc (mkClassPred cls rep_tys)
- ; let (rep_dict_id:sc_dict_ids)
- | null dicts = [instToId this_dict]
- | otherwise = map instToId dicts
-
- -- (Here, we are relying on the order of dictionary
- -- arguments built by NewTypeDerived in TcDeriv.)
-
- wrap_fn = mkCoTyLams tvs <.> mkCoLams (rep_dict_id:sc_dict_ids)
+ ; (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
- -- we need to find the kind that this class applies to
- -- and drop trailing tvs appropriately
- cls_kind = tyVarKind (head (reverse (tyConTyVars cls_tycon)))
- the_tvs = drop_tail (length (fst (splitFunTys cls_kind))) tvs
-
- coerced_rep_dict = mkHsCoerce (co_fn the_tvs cls_tycon cls_inst_tys) (HsVar rep_dict_id)
-
- body | null sc_dict_ids = coerced_rep_dict
- | otherwise = HsCase (noLoc coerced_rep_dict) $
- MatchGroup [the_match] (mkFunTy in_dict_ty inst_head)
- in_dict_ty = mkTyConApp cls_tycon cls_inst_tys
+ ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty
+ cls_tycon = classTyCon cls
+ the_coercion = make_coercion cls_tycon cls_inst_tys
+ coerced_rep_dict = mkHsWrap the_coercion (HsVar rep_dict_id)
- the_match = mkSimpleMatch [noLoc the_pat] the_rhs
- the_rhs = mkHsConApp cls_data_con cls_inst_tys (map HsVar (sc_dict_ids ++ op_ids))
-
- (uniqs1, uniqs2) = splitUniqSupply uniqs
-
- op_ids = zipWith (mkSysLocal FSLIT("op"))
- (uniqsFromSupply uniqs1) op_tys
-
- dict_ids = zipWith (mkSysLocal FSLIT("dict"))
- (uniqsFromSupply uniqs2) (map idType sc_dict_ids)
-
- the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
- pat_dicts = dict_ids,
- pat_binds = emptyLHsBinds,
- pat_args = PrefixCon (map nlVarPat op_ids),
- pat_ty = in_dict_ty}
-
- cls_data_con = classDataCon cls
- cls_tycon = dataConTyCon cls_data_con
- cls_arg_tys = dataConInstArgTys cls_data_con cls_inst_tys
-
- n_dict_args = if length dicts == 0 then 0 else length dicts - 1
- op_tys = drop n_dict_args cls_arg_tys
+ ; body <- make_body cls_tycon cls_inst_tys sc_dict_ids coerced_rep_dict
- dict = mkHsCoerce wrap_fn body
- ; return (unitBag (noLoc $ VarBind dfun_id (noLoc dict))) }
+ ; return (sc_binds `snocBag` (noLoc $ VarBind dfun_id $ noLoc $ mkHsWrap wrap_fn body)) }
where
- -- For newtype T a = MkT <ty>
- -- The returned coercion has kind :: C (T a):=:C <ty>
- co_fn tvs cls_tycon cls_inst_tys | Just co_con <- newTyConCo tycon
- = ExprCoFn (mkTyConApp cls_tycon (drop_tail 1 cls_inst_tys ++
- [mkSymCoercion (mkTyConApp co_con (map mkTyVarTy tvs))]))
- | otherwise
- = idCoercion
- drop_tail n l = take (length l - n) l
+
+ -----------------------
+ -- make_wrapper
+ -- We distinguish two cases:
+ -- (a) there is no tyvar abstraction in the dfun, so all dicts are constant,
+ -- and the new dict can just be a constant
+ -- (mb_preds = Just preds)
+ -- (b) there are tyvars, so we must make a dict *fun*
+ -- (mb_preds = Nothing)
+ -- See the defn of NewTypeDerived for the meaning of mb_preds
+ make_wrapper inst_loc tvs theta (Just preds) -- Case (a)
+ = ASSERT( null tvs && null theta )
+ do { dicts <- newDictBndrs inst_loc preds
+ ; 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, mkWpTyLams tvs <.> mkWpLams dict_ids, emptyBag) }
+
+ -----------------------
+ -- make_coercion
+ -- The inst_head looks like (C s1 .. sm (T a1 .. ak))
+ -- But we want the coercion (C s1 .. sm (sym (CoT a1 .. ak)))
+ -- with kind (C s1 .. sm (T a1 .. ak) :=: C s1 .. sm <rep_ty>)
+ -- where rep_ty is the (eta-reduced) type rep of T
+ -- 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_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)
+ = WpCo (mkTyConApp cls_tycon (all_tys_but_last ++ [co]))
+ | otherwise -- The newtype is transparent; no need for a cast
+ = idHsWrapper
+
+ -----------------------
+ -- make_body
+ -- Two cases; see Note [Newtype deriving superclasses] in TcDeriv.lhs
+ -- (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_tycon cls_inst_tys sc_dict_ids coerced_rep_dict
+ | null sc_dict_ids -- Case (a)
+ = return coerced_rep_dict
+ | otherwise -- Case (b)
+ = do { op_ids <- newSysLocalIds FSLIT("op") op_tys
+ ; dummy_sc_dict_ids <- newSysLocalIds FSLIT("sc") (map idType sc_dict_ids)
+ ; let the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
+ pat_dicts = dummy_sc_dict_ids,
+ pat_binds = emptyLHsBinds,
+ pat_args = PrefixCon (map nlVarPat op_ids),
+ 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 pat_ty pat_ty)) }
+ where
+ 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
------------------------
-- Ordinary instances
projects / ghc-hetmet.git / blobdiff