X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=8ff44ad05915aa7b0589a8e96c9f1d28897fe321;hb=ba16e1bfde86cc6d8fafa9be8a33b3b6172f262f;hp=df43f53e3b6ff3c984b7d6ae0485a67f72d774c9;hpb=030ecd78112d9db9a83d156d431a993cbcd64eab;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index df43f53..8ff44ad 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -31,6 +31,7 @@ import TypeRep import DataCon import Class import Var +import Id import MkId import Name import NameSet @@ -87,9 +88,9 @@ $tau_iop$ is the tau type for this instance of a class method \item $alpha$ is the class variable \item -$LIE_cop' = LIE_cop [X gammas_bar / alpha, fresh betas_bar]$ +$LIE_cop' = LIE_cop [X gammas_bar \/ alpha, fresh betas_bar]$ \item -$tau_cop' = tau_cop [X gammas_bar / alpha, fresh betas_bar]$ +$tau_cop' = tau_cop [X gammas_bar \/ alpha, fresh betas_bar]$ \end{enumerate} ToDo: Update the list above with names actually in the code. @@ -97,7 +98,7 @@ ToDo: Update the list above with names actually in the code. \begin{enumerate} \item First, make the LIEs for the class and instance contexts, which means -instantiate $thetaC [X inst_tyvars / alpha ]$, yielding LIElistC' and LIEC', +instantiate $thetaC [X inst_tyvars \/ alpha ]$, yielding LIElistC' and LIEC', and make LIElistI and LIEI. \item Then process each method in turn. @@ -136,7 +137,7 @@ tcInstDecls1 -- Deal with both source-code and imported instance decls -> [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; + [InstInfo Name], -- Source-code instance decls to process; -- contains all dfuns for this module HsValBinds Name) -- Supporting bindings for derived instances @@ -148,13 +149,12 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- (1) Do class and family instance declarations ; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls } - ; local_info_tycons <- mapM tcLocalInstDecl1 inst_decls - ; idx_tycons <- mapM tcIdxTyInstDeclTL idxty_decls + ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls + ; idx_tycons <- mapAndRecoverM tcIdxTyInstDeclTL idxty_decls - ; let { (local_infos, - at_tycons) = unzip local_info_tycons - ; local_info = concat local_infos - ; at_idx_tycon = concat at_tycons ++ catMaybes idx_tycons + ; let { (local_info, + at_tycons_s) = unzip local_info_tycons + ; at_idx_tycon = concat at_tycons_s ++ idx_tycons ; clas_decls = filter (isClassDecl.unLoc) tycl_decls ; implicit_things = concatMap implicitTyThings at_idx_tycon } @@ -203,19 +203,18 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls addErr $ assocInClassErr (tcdName decl) ; return tything } - isAssocFamily (Just (ATyCon tycon)) = + isAssocFamily (ATyCon tycon) = case tyConFamInst_maybe tycon of Nothing -> panic "isAssocFamily: no family?!?" Just (fam, _) -> isTyConAssoc fam - isAssocFamily (Just _ ) = panic "isAssocFamily: no tycon?!?" - isAssocFamily Nothing = False + 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] -> TcM a -> TcM a +addInsts :: [InstInfo Name] -> TcM a -> TcM a addInsts infos thing_inside = tcExtendLocalInstEnv (map iSpec infos) thing_inside @@ -230,15 +229,13 @@ addFamInsts tycons thing_inside \begin{code} tcLocalInstDecl1 :: LInstDecl Name - -> TcM ([InstInfo], [TyThing]) -- [] if there was an error + -> TcM (InstInfo Name, [TyThing]) -- A source-file instance declaration -- Type-check all the stuff before the "where" -- -- We check for respectable instance type, and context tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) - = -- Prime error recovery, set source location - recoverM (return ([], [])) $ - setSrcSpan loc $ + = setSrcSpan loc $ addErrCtxt (instDeclCtxt1 poly_ty) $ do { is_boot <- tcIsHsBoot @@ -247,27 +244,30 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ; (tyvars, theta, tau) <- tcHsInstHead poly_ty - -- Next, process any associated types. - ; idx_tycons <- mapM tcFamInstDecl 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 idx_tycons) + + -- Next, process any associated types. + ; idx_tycons <- recoverM (return []) $ + do { idx_tycons <- checkNoErrs $ mapAndRecoverM tcFamInstDecl ats + ; checkValidAndMissingATs clas (tyvars, inst_tys) + (zip ats idx_tycons) + ; return idx_tycons } -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.) - ; dfun_name <- newDFunName clas inst_tys loc + ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty) + -- Dfun location is that of instance *header* ; overlap_flag <- getOverlapFlag ; let (eq_theta,dict_theta) = partition isEqPred theta theta' = eq_theta ++ dict_theta dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys ispec = mkLocalInstance dfun overlap_flag - ; return ([InstInfo { iSpec = ispec, - iBinds = VanillaInst binds uprags }], - catMaybes idx_tycons) + ; return (InstInfo { iSpec = ispec, + iBinds = VanillaInst binds uprags }, + idx_tycons) } where -- We pass in the source form and the type checked form of the ATs. We @@ -276,7 +276,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) checkValidAndMissingATs :: Class -> ([TyVar], [TcType]) -- instance types -> [(LTyClDecl Name, -- source form of AT - Maybe TyThing)] -- Core form of AT + 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 @@ -294,9 +294,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ; mapM_ (checkIndexes clas inst_tys) ats } - checkIndexes _ _ (_, Nothing) = - return () -- skip, we already had an error here - checkIndexes clas inst_tys (hsAT, Just (ATyCon tycon)) = + checkIndexes clas inst_tys (hsAT, ATyCon tycon) = -- !!!TODO: check that this does the Right Thing for indexed synonyms, too! checkIndexes' clas inst_tys hsAT (tyConTyVars tycon, @@ -371,7 +369,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) %************************************************************************ \begin{code} -tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo] +tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name] -> TcM (LHsBinds Id, TcLclEnv) -- (a) From each class declaration, -- generate any default-method bindings @@ -457,7 +455,7 @@ is the @dfun_theta@ below. \begin{code} -tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id) +tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id) -- Returns a binding for the dfun ------------------------ @@ -582,7 +580,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) dfun_id = instanceDFunId ispec rigid_info = InstSkol inst_ty = idType dfun_id - loc = srcLocSpan (getSrcLoc dfun_id) + loc = getSrcSpan dfun_id in -- Prime error recovery recoverM (return emptyLHsBinds) $