X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=d4d8d2fbc543e6133eee500eb3955fdcca77a9e6;hp=f4e338d096c2a19f18776fa63d42d6bd84719973;hb=HEAD;hpb=3d16d9d805e321c58459d0b62223591c19013060 diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index f4e338d..d4d8d2f 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -13,26 +13,27 @@ import TcBinds import TcTyClsDecls import TcClassDcl import TcPat( addInlinePrags ) -import TcSimplify( simplifyTop ) import TcRnMonad import TcMType import TcType +import BuildTyCl import Inst import InstEnv import FamInst import FamInstEnv -import MkCore ( nO_METHOD_BINDING_ERROR_ID ) import TcDeriv import TcEnv import RnSource ( addTcgDUs ) import TcHsType import TcUnify +import MkCore ( nO_METHOD_BINDING_ERROR_ID ) import Type import Coercion import TyCon import DataCon import Class import Var +import Pair import VarSet import CoreUtils ( mkPiTypes ) import CoreUnfold ( mkDFunUnfolding ) @@ -207,7 +208,7 @@ Just . Instead, we simply rely on the fact that casts are cheap: $df :: forall a. C a => C [a] - {-# INLINE df #} -- NB: INLINE this + {-# INLINE df #-} -- NB: INLINE this $df = /\a. \d. MkC [a] ($cop_list a d) = $cop_list |> forall a. C a -> (sym (Co:C [a])) @@ -371,40 +372,41 @@ tcInstDecls1 tycl_decls inst_decls deriv_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 = mkRecSelBinds at_idx_tycons - } + ; implicit_things = concatMap implicitTyConThings at_idx_tycons + ; aux_binds = mkRecSelBinds at_idx_tycons } -- (2) Add the tycons of indexed types and their implicit -- tythings to the global environment - ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do { + ; tcExtendGlobalEnv (map ATyCon at_idx_tycons ++ implicit_things) $ do { - -- (3) Instances from generic class declarations - ; generic_inst_info <- getGenericInstances clas_decls -- Next, construct the instance environment so far, consisting -- of -- (a) local instance decls - -- (b) generic instances - -- (c) local family instance decls + -- (b) local family instance decls ; addInsts local_info $ - addInsts generic_inst_info $ addFamInsts at_idx_tycons $ do { - -- (4) Compute instances from "deriving" clauses; + -- (3) 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 -- NB: class instance declarations can contain derivings as -- part of associated data type declarations - failIfErrsM -- If the addInsts stuff gave any errors, don't - -- try the deriving stuff, becuase that may give - -- more errors still - ; (deriv_inst_info, deriv_binds, deriv_dus) + failIfErrsM -- If the addInsts stuff gave any errors, don't + -- try the deriving stuff, because that may give + -- more errors still + ; (deriv_inst_info, deriv_binds, deriv_dus, deriv_tys, deriv_ty_insts) <- tcDeriving tycl_decls inst_decls deriv_decls - ; gbl_env <- addInsts deriv_inst_info getGblEnv + + -- Extend the global environment also with the generated datatypes for + -- the generic representation + ; let all_tycons = map ATyCon (deriv_tys ++ deriv_ty_insts) + ; gbl_env <- tcExtendGlobalEnv all_tycons $ + tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $ + addFamInsts deriv_ty_insts $ + addInsts deriv_inst_info getGblEnv ; return ( addTcgDUs gbl_env deriv_dus, - generic_inst_info ++ deriv_inst_info ++ local_info, + deriv_inst_info ++ local_info, aux_binds `plusHsValBinds` deriv_binds) }}} @@ -412,18 +414,14 @@ addInsts :: [InstInfo Name] -> TcM a -> TcM a addInsts infos thing_inside = tcExtendLocalInstEnv (map iSpec infos) thing_inside -addFamInsts :: [TyThing] -> TcM a -> TcM a +addFamInsts :: [TyCon] -> 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) + = tcExtendLocalFamInstEnv (map mkLocalFamInst tycons) thing_inside \end{code} \begin{code} tcLocalInstDecl1 :: LInstDecl Name - -> TcM (InstInfo Name, [TyThing]) + -> TcM (InstInfo Name, [TyCon]) -- A source-file instance declaration -- Type-check all the stuff before the "where" -- @@ -467,7 +465,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) checkValidAndMissingATs :: Class -> ([TyVar], [TcType]) -- instance types -> [(LTyClDecl Name, -- source form of AT - TyThing)] -- Core form of AT + TyCon)] -- Core form of AT -> TcM () checkValidAndMissingATs clas inst_tys ats = do { -- Issue a warning for each class AT that is not defined in this @@ -485,12 +483,11 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ; mapM_ (checkIndexes clas inst_tys) ats } - checkIndexes clas inst_tys (hsAT, ATyCon tycon) + checkIndexes clas inst_tys (hsAT, 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) - checkIndexes _ _ _ = panic "checkIndexes" checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys) = let atName = tcdName . unLoc $ hsAT @@ -550,8 +547,8 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) | isTyVarTy ty = return () | otherwise = addErrTc $ mustBeVarArgErr ty checkIndex ty (Just instTy) - | ty `tcEqType` instTy = return () - | otherwise = addErrTc $ wrongATArgErr ty instTy + | ty `eqType` instTy = return () + | otherwise = addErrTc $ wrongATArgErr ty instTy listToNameSet = addListToNameSet emptyNameSet @@ -564,7 +561,182 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) tv1 `sameLexeme` tv2 = nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2) in - extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement + TcType.extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement +\end{code} + + +%************************************************************************ +%* * + Type checking family instances +%* * +%************************************************************************ + +Family instances are somewhat of a hybrid. They are processed together with +class instance heads, but can contain data constructors and hence they share a +lot of kinding and type checking code with ordinary algebraic data types (and +GADTs). + +\begin{code} +tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyCon +tcFamInstDecl top_lvl (L loc decl) + = -- Prime error recovery, set source location + setSrcSpan loc $ + tcAddDeclCtxt decl $ + do { -- type family instances require -XTypeFamilies + -- and can't (currently) be in an hs-boot file + ; type_families <- xoptM Opt_TypeFamilies + ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + ; checkTc type_families $ badFamInstDecl (tcdLName decl) + ; checkTc (not is_boot) $ badBootFamInstDeclErr + + -- Perform kind and type checking + ; tc <- tcFamInstDecl1 decl + ; checkValidTyCon tc -- Remember to check validity; + -- no recursion to worry about here + + -- Check that toplevel type instances are not for associated types. + ; when (isTopLevel top_lvl && isAssocFamily tc) + (addErr $ assocInClassErr (tcdName decl)) + + ; return tc } + +isAssocFamily :: TyCon -> Bool -- Is an assocaited type +isAssocFamily tycon + = case tyConFamInst_maybe tycon of + Nothing -> panic "isAssocFamily: no family?!?" + Just (fam, _) -> isTyConAssoc fam + +assocInClassErr :: Name -> SDoc +assocInClassErr name + = ptext (sLit "Associated type") <+> quotes (ppr name) <+> + ptext (sLit "must be inside a class instance") + + + +tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon + + -- "type instance" +tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) + = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> + do { -- check that the family declaration is for a synonym + checkTc (isFamilyTyCon family) (notFamily family) + ; checkTc (isSynTyCon family) (wrongKindOfFamily family) + + ; -- (1) kind check the right-hand side of the type equation + ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk) + -- ToDo: the ExpKind could be better + + -- we need the exact same number of type parameters as the family + -- declaration + ; let famArity = tyConArity family + ; checkTc (length k_typats == famArity) $ + wrongNumberOfParmsErr famArity + + -- (2) type check type equation + ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars + ; t_typats <- mapM tcHsKindedType k_typats + ; t_rhs <- tcHsKindedType k_rhs + + -- (3) check the well-formedness of the instance + ; checkValidTypeInst t_typats t_rhs + + -- (4) construct representation tycon + ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc + ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) + (typeKind t_rhs) + NoParentTyCon (Just (family, t_typats)) + }} + + -- "newtype instance" and "data instance" +tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, + tcdCons = cons}) + = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon -> + do { -- check that the family declaration is for the right kind + checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon) + ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon) + + ; -- (1) kind check the data declaration as usual + ; k_decl <- kcDataDecl decl k_tvs + ; let k_ctxt = tcdCtxt k_decl + k_cons = tcdCons k_decl + + -- result kind must be '*' (otherwise, we have too few patterns) + ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon) + + -- (2) type check indexed data type declaration + ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars + + -- kind check the type indexes and the context + ; t_typats <- mapM tcHsKindedType k_typats + ; stupid_theta <- tcHsKindedContext k_ctxt + + -- (3) Check that + -- (a) left-hand side contains no type family applications + -- (vanilla synonyms are fine, though, and we checked for + -- foralls earlier) + ; mapM_ checkTyFamFreeness t_typats + + ; dataDeclChecks tc_name new_or_data stupid_theta k_cons + + -- (4) construct representation tycon + ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc + ; let ex_ok = True -- Existentials ok for type families! + ; fixM (\ rep_tycon -> do + { let orig_res_ty = mkTyConApp fam_tycon t_typats + ; data_cons <- tcConDecls ex_ok rep_tycon + (t_tvs, orig_res_ty) k_cons + ; tc_rhs <- + case new_or_data of + DataType -> return (mkDataTyConRhs data_cons) + NewType -> ASSERT( not (null data_cons) ) + mkNewTyConRhs rep_tc_name rep_tycon (head data_cons) + ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive + h98_syntax NoParentTyCon (Just (fam_tycon, t_typats)) + -- We always assume that indexed types are recursive. Why? + -- (1) Due to their open nature, we can never be sure that a + -- further instance might not introduce a new recursive + -- dependency. (2) They are always valid loop breakers as + -- they involve a coercion. + }) + }} + where + h98_syntax = case cons of -- All constructors have same shape + L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False + _ -> True + +tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d) + +-- Kind checking of indexed types +-- - + +-- Kind check type patterns and kind annotate the embedded type variables. +-- +-- * Here we check that a type instance matches its kind signature, but we do +-- not check whether there is a pattern for each type index; the latter +-- check is only required for type synonym instances. + +kcIdxTyPats :: TyClDecl Name + -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a) + -- ^^kinded tvs ^^kinded ty pats ^^res kind + -> TcM a +kcIdxTyPats decl thing_inside + = kcHsTyVars (tcdTyVars decl) $ \tvs -> + do { let tc_name = tcdLName decl + ; fam_tycon <- tcLookupLocatedTyCon tc_name + ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon) + ; hs_typats = fromJust $ tcdTyPats decl } + + -- we may not have more parameters than the kind indicates + ; checkTc (length kinds >= length hs_typats) $ + tooManyParmsErr (tcdLName decl) + + -- type functions can have a higher-kinded result + ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind + ; typats <- zipWithM kcCheckLHsType hs_typats + [ EK kind (EkArg (ppr tc_name) n) + | (kind,n) <- kinds `zip` [1..]] + ; thing_inside tvs typats resultKind fam_tycon + } \end{code} @@ -621,7 +793,10 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) setSrcSpan loc $ addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ do { -- Instantiate the instance decl with skolem constants - ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolSigType skol_info (idType dfun_id) + ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id) + -- We instantiate the dfun_id with superSkolems. + -- See Note [Subtle interaction of recursion and overlap] + -- and Note [Binding when looking up instances] ; let (clas, inst_tys) = tcSplitDFunHead inst_head (class_tyvars, sc_theta, _, op_items) = classBigSig clas sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta @@ -633,20 +808,19 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) ; orig_ev_vars <- newEvVars orig_theta ; let dfun_ev_vars = silent_ev_vars ++ orig_ev_vars - ; (sc_binds, sc_dicts, sc_args) - <- mapAndUnzip3M (tcSuperClass n_ty_args dfun_ev_vars) sc_theta' + ; (sc_dicts, sc_args) + <- mapAndUnzipM (tcSuperClass n_ty_args dfun_ev_vars) sc_theta' -- Check that any superclasses gotten from a silent arguemnt -- can be deduced from the originally-specified dfun arguments ; ct_loc <- getCtLoc ScOrigin ; _ <- checkConstraints skol_info inst_tyvars orig_ev_vars $ - emitConstraints $ listToBag $ - [ WcEvVar (WantedEvVar sc ct_loc) - | sc <- sc_dicts, isSilentEvVar sc ] + emitFlats $ listToBag $ + [ mkEvVarX sc ct_loc | sc <- sc_dicts, isSilentEvVar sc ] -- Deal with 'SPECIALISE instance' pragmas -- See Note [SPECIALISE instance pragmas] - ; spec_info <- tcSpecInstPrags dfun_id ibinds + ; spec_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds -- Typecheck the methods ; (meth_ids, meth_binds) @@ -693,42 +867,35 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) main_bind = AbsBinds { abs_tvs = inst_tyvars , abs_ev_vars = dfun_ev_vars , abs_exports = [(inst_tyvars, dfun_id_w_fun, self_dict, - SpecPrags [] {- spec_inst_prags -})] + SpecPrags spec_inst_prags)] , abs_ev_binds = emptyTcEvBinds , abs_binds = unitBag dict_bind } ; return (unitBag (L loc main_bind) `unionBags` - unionManyBags sc_binds `unionBags` listToBag meth_binds) } where - skol_info = InstSkol -- See Note [Subtle interaction of recursion and overlap] + skol_info = InstSkol dfun_ty = idType dfun_id dfun_id = instanceDFunId ispec loc = getSrcSpan dfun_id ------------------------------ -tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (LHsBinds Id, Id, DFunArg CoreExpr) +tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (EvVar, DFunArg CoreExpr) +-- All superclasses should be either +-- (a) be one of the arguments to the dfun, of +-- (b) be a constant, soluble at top level tcSuperClass n_ty_args ev_vars pred | Just (ev, i) <- find n_ty_args ev_vars - = return (emptyBag, ev, DFunLamArg i) + = return (ev, DFunLamArg i) | otherwise - = ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred) - do { sc_dict <- newWantedEvVar pred - ; loc <- getCtLoc ScOrigin - ; ev_binds <- simplifyTop (unitBag (WcEvVar (WantedEvVar sc_dict loc))) - ; let ev_wrap = WpLet (EvBinds ev_binds) - sc_bind = mkVarBind sc_dict (noLoc $ (wrapId ev_wrap sc_dict)) - ; return (unitBag sc_bind, sc_dict, DFunConstArg (Var sc_dict)) } - -- It's very important to solve the superclass constraint *in isolation* - -- so that it isn't generated by superclass selection from something else - -- We then generate the (also rather degenerate) top-level binding: - -- sc_dict = let sc_dict = in sc_dict - -- where is generated by solving the implication constraint + = ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred) -- Constant! + do { sc_dict <- emitWanted ScOrigin pred + ; return (sc_dict, DFunConstArg (Var sc_dict)) } where find _ [] = Nothing - find i (ev:evs) | pred `tcEqPred` evVarPred ev = Just (ev, i) - | otherwise = find (i+1) evs + find i (ev:evs) | pred `eqPred` evVarPred ev = Just (ev, i) + | otherwise = find (i+1) evs ------------------------------ tcSpecInstPrags :: DFunId -> InstBindings Name @@ -863,7 +1030,7 @@ tcSpecInst dfun_id prag@(SpecInstSig hs_ty) ; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty ; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys - ; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt) + ; co_fn <- tcSubType (SpecPragOrigin name) SpecInstCtxt (idType dfun_id) spec_dfun_ty ; return (SpecPrag dfun_id co_fn defaultInlinePragma) } where @@ -926,10 +1093,15 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ---------------------- tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id) + + tc_default sel_id (GenDefMeth dm_name) + = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name + ; tc_body sel_id False {- Not generated code? -} meth_bind } +{- tc_default sel_id GenDefMeth -- Derivable type classes stuff = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id ; tc_body sel_id False {- Not generated code? -} meth_bind } - +-} tc_default sel_id NoDefMeth -- No default method at all = do { warnMissingMethod sel_id ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars @@ -1051,13 +1223,12 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys inst_tvs = fst (tcSplitForAllTys (idType dfun_id)) Just (init_inst_tys, _) = snocView inst_tys - rep_ty = fst (coercionKind co) -- [p] + rep_ty = pFst (coercionKind co) -- [p] rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty]) -- co : [p] ~ T p - co = substTyWith inst_tvs (mkTyVarTys tyvars) $ - case coi of { IdCo ty -> ty ; - ACo co -> mkSymCoercion co } + co = substCoWithTys inst_tvs (mkTyVarTys tyvars) $ + mkSymCo coi ---------------- tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId) @@ -1081,7 +1252,8 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ---------------- mk_op_wrapper :: Id -> EvVar -> HsWrapper mk_op_wrapper sel_id rep_d - = WpCast (substTyWith sel_tvs (init_inst_tys ++ [co]) local_meth_ty) + = WpCast (liftCoSubstWith sel_tvs (map mkReflCo init_inst_tys ++ [co]) + local_meth_ty) <.> WpEvApp (EvId rep_d) <.> mkWpTyApps (init_inst_tys ++ [rep_ty]) where @@ -1249,7 +1421,7 @@ instDeclCtxt2 :: Type -> SDoc instDeclCtxt2 dfun_ty = inst_decl_ctxt (ppr (mkClassPred cls tys)) where - (_,cls,tys) = tcSplitDFunTy dfun_ty + (_,_,cls,tys) = tcSplitDFunTy dfun_ty inst_decl_ctxt :: SDoc -> SDoc inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc @@ -1271,4 +1443,37 @@ wrongATArgErr ty instTy = , ptext (sLit "Found") <+> quotes (ppr ty) <+> ptext (sLit "but expected") <+> quotes (ppr instTy) ] + +tooManyParmsErr :: Located Name -> SDoc +tooManyParmsErr tc_name + = ptext (sLit "Family instance has too many parameters:") <+> + quotes (ppr tc_name) + +tooFewParmsErr :: Arity -> SDoc +tooFewParmsErr arity + = ptext (sLit "Family instance has too few parameters; expected") <+> + ppr arity + +wrongNumberOfParmsErr :: Arity -> SDoc +wrongNumberOfParmsErr exp_arity + = ptext (sLit "Number of parameters must match family declaration; expected") + <+> ppr exp_arity + +badBootFamInstDeclErr :: SDoc +badBootFamInstDeclErr + = ptext (sLit "Illegal family instance in hs-boot file") + +notFamily :: TyCon -> SDoc +notFamily tycon + = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon) + , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))] + +wrongKindOfFamily :: TyCon -> SDoc +wrongKindOfFamily family + = ptext (sLit "Wrong category of family instance; declaration was for a") + <+> kindOfFamily + where + kindOfFamily | isSynTyCon family = ptext (sLit "type synonym") + | isAlgTyCon family = ptext (sLit "data type") + | otherwise = pprPanic "wrongKindOfFamily" (ppr family) \end{code}