X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=fe7b1d8b24254915b5335c724569cf62a4f874e7;hp=e186b365fa73f57eda73c559db1e9078bcb66b02;hb=84923cc7de2a93c22a2f72daf9ac863959efae13;hpb=d76c18e05f6366c23144624b696a02fbaa6d26e8 diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index e186b36..fe7b1d8 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -1,7 +1,9 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[TcInstDecls]{Typechecking instance declarations} + +TcInstDecls: Typechecking instance declarations \begin{code} module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where @@ -9,55 +11,43 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where #include "HsVersions.h" import HsSyn -import TcBinds ( mkPragFun, tcPrags, badBootDeclErr ) -import TcTyClsDecls ( tcIdxTyInstDecl ) -import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr, badATErr, - omittedATWarn, tcClassDecl2, getGenericInstances ) +import TcBinds +import TcTyClsDecls +import TcClassDcl import TcRnMonad -import TcMType ( tcSkolSigType, checkValidInstance, - checkValidInstHead ) -import TcType ( TcType, mkClassPred, tcSplitSigmaTy, - tcSplitDFunHead, SkolemInfo(InstSkol), - tcSplitDFunTy, mkFunTy ) -import Inst ( newDictBndr, newDictBndrs, instToId, showLIE, - getOverlapFlag, tcExtendLocalInstEnv ) -import InstEnv ( mkLocalInstance, instanceDFunId ) -import TcDeriv ( tcDeriving ) -import TcEnv ( InstInfo(..), InstBindings(..), - newDFunName, tcExtendIdEnv, tcExtendGlobalEnv - ) -import TcHsType ( kcHsSigType, tcHsKindedType ) -import TcUnify ( checkSigTyVars ) -import TcSimplify ( tcSimplifySuperClasses ) -import Type ( zipOpenTvSubst, substTheta, mkTyConApp, mkTyVarTy, - splitFunTys, TyThing(ATyCon), isTyVarTy, tcEqType, - substTys, emptyTvSubst, extendTvSubst ) -import Coercion ( mkSymCoercion ) -import TyCon ( TyCon, tyConName, newTyConCo_maybe, tyConTyVars, - isTyConAssoc, tyConFamInst_maybe, - 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 MkId ( mkDictFunId ) -import Name ( Name, getSrcLoc, nameOccName ) -import NameSet ( addListToNameSet, emptyNameSet, minusNameSet, - nameSetToList ) -import Maybe ( isNothing, 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 TcMType +import TcType +import Inst +import InstEnv +import FamInst +import FamInstEnv +import TcDeriv +import TcEnv +import TcHsType +import TcUnify +import TcSimplify +import Type +import Coercion +import TyCon +import DataCon +import Class +import Var +import MkId +import Name +import NameSet +import DynFlags +import SrcLoc +import ListSetOps +import Util import Outputable import Bag -import BasicTypes ( Activation( AlwaysActive ), InlineSpec(..) ) -import HscTypes ( implicitTyThings ) +import BasicTypes +import HscTypes import FastString + +import Data.Maybe +import Control.Monad hiding (zipWithM_, mapAndUnzipM) +import Data.List \end{code} Typechecking instance declarations is done in two passes. The first @@ -145,12 +135,13 @@ Gather up the instance declarations from their various sources 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 @@ -160,22 +151,19 @@ tcInstDecls1 tycl_decls inst_decls -- 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 @@ -184,30 +172,32 @@ tcInstDecls1 tycl_decls inst_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 @@ -223,7 +213,15 @@ assocInClassErr name = addInsts :: [InstInfo] -> TcM a -> TcM a addInsts infos thing_inside = tcExtendLocalInstEnv (map iSpec infos) thing_inside -\end{code} + +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} tcLocalInstDecl1 :: LInstDecl Name @@ -242,20 +240,16 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags)) badBootDeclErr - -- Typecheck the instance type itself. We can't use - -- tcHsSigType, because it's not a valid user type. - ; kinded_ty <- kcHsSigType poly_ty - ; poly_ty' <- tcHsKindedType kinded_ty - ; let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty' + ; (tyvars, theta, tau) <- tcHsInstHead 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.) @@ -263,13 +257,10 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) ; 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 @@ -278,8 +269,7 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) 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 @@ -297,11 +287,10 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) ; 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) @@ -470,92 +459,121 @@ tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id) -- 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 + rigid_info = InstSkol 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 + ; 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) - 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 - - 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 - -- The returned coercion has kind :: C (T a):=:C - co_fn tvs cls_tycon cls_inst_tys | Just co_con <- newTyConCo_maybe 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 inst_loc [] 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 ) + -- 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 @@ -563,7 +581,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) = let dfun_id = instanceDFunId ispec - rigid_info = InstSkol dfun_id + rigid_info = InstSkol inst_ty = idType dfun_id in -- Prime error recovery @@ -589,7 +607,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) newDictBndrs sc_loc sc_theta' `thenM` \ sc_dicts -> getInstLoc origin `thenM` \ inst_loc -> newDictBndrs inst_loc dfun_theta' `thenM` \ dfun_arg_dicts -> - newDictBndr inst_loc (mkClassPred clas inst_tys') `thenM` \ this_dict -> + newDictBndr inst_loc (mkClassPred clas inst_tys') `thenM` \ this_dict -> -- Default-method Ids may be mentioned in synthesised RHSs, -- but they'll already be in the environment. @@ -605,9 +623,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) -- Don't include this_dict in the 'givens', else -- sc_dicts get bound by just selecting from this_dict!! addErrCtxt superClassCtxt - (tcSimplifySuperClasses inst_tyvars' - dfun_arg_dicts - sc_dicts) `thenM` \ sc_binds -> + (tcSimplifySuperClasses inst_loc + dfun_arg_dicts sc_dicts) `thenM` \ sc_binds -> -- It's possible that the superclass stuff might unified one -- of the inst_tyavars' with something in the envt