From dfcf88523ec5988fbcaa2cbf812cc5862ad621cf Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Tue, 15 Aug 2006 12:34:02 +0000 Subject: [PATCH] Allow class and instance decls in hs-boot files For some reason, in 6.5 the manual said you could put a class decl in an interface file, but not an instance decl; whereas the implementation was exactly the othe way round. This patch makes it possible to put *both* class and instance decls in an interface file. I also did a bit of re-factoring; comparing the declarations in the hs-boot and hs file is now done by converting to IfaceSyn, because we have good comparison operations for IfaceSyn already implemented. This fixed a bug that previously let through an inconsistent declaration of a data type. The remaining infelicity concerns "abstract" TyCons. They are a bit of a hack anyway; and Classes are not handled in the same way. Need to think about this, but I think it's probably ok as it stands. --- compiler/iface/IfaceSyn.lhs | 44 ++++++++++++++++++++- compiler/iface/TcIface.lhs | 2 + compiler/typecheck/TcRnDriver.lhs | 61 +++++++++++------------------ compiler/typecheck/TcTyClsDecls.lhs | 3 -- docs/users_guide/separate_compilation.xml | 8 ++-- 5 files changed, 73 insertions(+), 45 deletions(-) diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 4563714..8e92adc 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -27,7 +27,7 @@ module IfaceSyn ( -- Equality IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy, - eqIfDecl, eqIfInst, eqIfRule, + eqIfDecl, eqIfInst, eqIfRule, checkBootDecl, -- Pretty printing pprIfaceExpr, pprIfaceDecl, pprIfaceDeclHead @@ -732,6 +732,11 @@ bool :: Bool -> IfaceEq bool True = Equal bool False = NotEqual +toBool :: IfaceEq -> Bool +toBool Equal = True +toBool (EqBut _) = True +toBool NotEqual = False + zapEq :: IfaceEq -> IfaceEq -- Used to forget EqBut information zapEq (EqBut _) = Equal zapEq other = other @@ -757,6 +762,43 @@ eqIfExt n1 n2 = NotEqual \begin{code} --------------------- +checkBootDecl :: IfaceDecl -- The boot decl + -> IfaceDecl -- The real decl + -> Bool -- True <=> compatible +checkBootDecl (IfaceId s1 t1 _) (IfaceId s2 t2 _) + = ASSERT( s1==s2 ) toBool (t1 `eqIfType` t2) + +checkBootDecl d1@(IfaceForeign {}) d2@(IfaceForeign {}) + = ASSERT (ifName d1 == ifName d2 ) ifExtName d1 == ifExtName d2 + +checkBootDecl d1@(IfaceSyn {}) d2@(IfaceSyn {}) + = ASSERT( ifName d1 == ifName d2 ) + toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env -> + eq_ifType env (ifSynRhs d1) (ifSynRhs d2) + +checkBootDecl d1@(IfaceData {}) d2@(IfaceData {}) +-- We don't check the recursion flags because the boot-one is +-- recursive, to be conservative, but the real one may not be. +-- I'm not happy with the way recursive flags are dealt with. + = ASSERT( ifName d1 == ifName d2 ) + toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env -> + eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& + case ifCons d1 of + IfAbstractTyCon -> Equal + cons1 -> eq_hsCD env cons1 (ifCons d2) + +checkBootDecl d1@(IfaceClass {}) d2@(IfaceClass {}) + = ASSERT( ifName d1 == ifName d2 ) + toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env -> + eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&& + case (ifCtxt d1, ifSigs d1) of + ([], []) -> Equal + (cxt1, sigs1) -> eq_ifContext env cxt1 (ifCtxt d2) &&& + eqListBy (eq_cls_sig env) sigs1 (ifSigs d2) + +checkBootDecl _ _ = False -- default case + +--------------------- eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2) = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index bd31cc0..92d3997 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -376,6 +376,8 @@ tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, tcIfaceDecl (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, ifTyVars = tv_bndrs, ifFDs = rdr_fds, ifSigs = rdr_sigs, ifVrcs = tc_vrcs, ifRec = tc_isrec }) +-- ToDo: in hs-boot files we should really treat abstract classes specially, +-- as we do abstract tycons = bindIfaceTyVars tv_bndrs $ \ tyvars -> do { cls_name <- lookupIfaceTop occ_name ; ctxt <- tcIfaceCtxt rdr_ctxt diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 7adb9d5..8aeab69 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -38,7 +38,7 @@ import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv ) import TcHsSyn ( zonkTopDecls ) import TcExpr ( tcInferRho ) import TcRnMonad -import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith ) +import TcType ( tidyTopType, tcEqType ) import Inst ( showLIE ) import InstEnv ( extendInstEnvList, Instance, pprInstances, instanceDFunId ) import TcBinds ( tcTopBinds, tcHsBootSigs ) @@ -48,6 +48,7 @@ import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) import TcIface ( tcExtCoreBindings, tcHiBootIface ) +import IfaceSyn ( checkBootDecl, tyThingToIfaceDecl, IfaceExtName(..) ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) import LoadIface ( loadOrphanModules ) @@ -58,7 +59,6 @@ import RnEnv ( lookupSrcOcc_maybe ) import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec ) import PprCore ( pprRules, pprCoreBindings ) import CoreSyn ( CoreRule, bindersOfBinds ) -import DataCon ( dataConWrapId ) import ErrUtils ( Messages, mkDumpDoc, showPass ) import Id ( Id, mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) @@ -66,16 +66,16 @@ import Module import UniqFM ( elemUFM, eltsUFM ) import OccName ( mkVarOccFS, plusOccEnv ) import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName, - mkExternalName ) + nameModule, nameOccName, isImplicitName, mkExternalName ) import NameSet -import TyCon ( tyConHasGenerics, isSynTyCon, synTyConDefn, tyConKind ) +import TyCon ( tyConHasGenerics ) import SrcLoc ( srcLocSpan, Located(..), noLoc ) import DriverPhases ( HscSource(..), isHsBoot ) import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails, HscEnv(..), ExternalPackageState(..), IsBootInterface, noDependencies, Deprecs( NoDeprecs ), plusDeprecs, - ForeignStubs(NoStubs), TyThing(..), + ForeignStubs(NoStubs), TypeEnv, lookupTypeEnv, hptInstances, extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts, emptyFixityEnv @@ -113,7 +113,7 @@ import TysWiredIn ( mkListTy, unitTy ) import IdInfo ( GlobalIdDetails(..) ) import Kind ( Kind ) import Var ( globaliseId ) -import Name ( nameOccName, nameModule, isBuiltInSyntax, isInternalName ) +import Name ( nameModule, isBuiltInSyntax, isInternalName ) import OccName ( isTcOcc ) import NameEnv ( delListFromNameEnv ) import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName, @@ -509,24 +509,35 @@ checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id) checkHiBootIface (TcGblEnv { tcg_insts = local_insts, tcg_type_env = local_type_env }) (ModDetails { md_insts = boot_insts, md_types = boot_type_env }) - = do { mapM_ check_one (typeEnvElts boot_type_env) + = do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts)) ; + ; mapM_ check_one (typeEnvElts boot_type_env) ; dfun_binds <- mapM check_inst boot_insts ; return (unionManyBags dfun_binds) } where check_one boot_thing | no_check name = return () - | otherwise - = case lookupTypeEnv local_type_env name of - Nothing -> addErrTc (missingBootThing boot_thing) - Just real_thing -> check_thing boot_thing real_thing + | Just real_thing <- lookupTypeEnv local_type_env name + = do { let boot_decl = tyThingToIfaceDecl ext_nm boot_thing + real_decl = tyThingToIfaceDecl ext_nm real_thing + ; checkTc (checkBootDecl boot_decl real_decl) + (bootMisMatch boot_thing boot_decl real_decl) } + -- The easiest way to check compatibility is to convert to + -- iface syntax, where we already have good comparison functions + | otherwise + = addErrTc (missingBootThing boot_thing) where name = getName boot_thing + ext_nm name = ExtPkg (nameModule name) (nameOccName name) + -- Just enough to compare; no versions etc needed + no_check name = isWiredInName name -- No checking for wired-in names. In particular, -- 'error' is handled by a rather gross hack -- (see comments in GHC.Err.hs-boot) || name `elem` dfun_names + || isImplicitName name -- Has a parent, which we'll check + dfun_names = map getName boot_insts check_inst boot_inst @@ -541,35 +552,9 @@ checkHiBootIface local_boot_dfun = mkExportedLocalId (idName boot_dfun) boot_inst_ty ---------------- -check_thing (ATyCon boot_tc) (ATyCon real_tc) - | isSynTyCon boot_tc && isSynTyCon real_tc, - defn1 `tcEqType` substTyWith tvs2 (mkTyVarTys tvs1) defn2 - = return () - - | tyConKind boot_tc == tyConKind real_tc - = return () - where - (tvs1, defn1) = synTyConDefn boot_tc - (tvs2, defn2) = synTyConDefn boot_tc - -check_thing (AnId boot_id) (AnId real_id) - | idType boot_id `tcEqType` idType real_id - = return () - -check_thing (ADataCon dc1) (ADataCon dc2) - | idType (dataConWrapId dc1) `tcEqType` idType (dataConWrapId dc2) - = return () - - -- Can't declare a class in a hi-boot file - -check_thing boot_thing real_thing -- Default case; failure - = addErrAt (srcLocSpan (getSrcLoc real_thing)) - (bootMisMatch real_thing) - ----------------- missingBootThing thing = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module") -bootMisMatch thing +bootMisMatch thing boot_decl real_decl = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file") instMisMatch inst = hang (ppr inst) diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 1a9d4c0..e5eeac8 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -323,7 +323,6 @@ kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs}) = kcTyClDeclBody decl $ \ tvs' -> do { is_boot <- tcIsHsBoot - ; checkTc (not is_boot) badBootClassDeclErr ; ctxt' <- kcHsContext ctxt ; sigs' <- mappM (wrapLocM kc_sig) sigs ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs'}) } @@ -824,6 +823,4 @@ newtypeFieldErr con_name n_flds emptyConDeclsErr tycon = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), nest 2 $ ptext SLIT("(-fglasgow-exts permits this)")] - -badBootClassDeclErr = ptext SLIT("Illegal class declaration in hs-boot file") \end{code} diff --git a/docs/users_guide/separate_compilation.xml b/docs/users_guide/separate_compilation.xml index c33ff21..696d687 100644 --- a/docs/users_guide/separate_compilation.xml +++ b/docs/users_guide/separate_compilation.xml @@ -816,12 +816,14 @@ can be given abstractly, by omitting the '=' sign and everything that follows. data R (x :: * -> *) y +You cannot use deriving on a data type declaration; write in +instance declaration instead. Class declarations is exactly as in Haskell, except that you may not put -default method declarations. You can also omit all the class methods entirely. +default method declarations. You can also omit all the superclasses and class +methods entirely; but you must either omit them all or put them all in. - Do not include instance declarations. There is a complication to do with -how the dictionary functions are named. It may well work, but it's not a well-tested feature. + You can include instance declarations just as in Haskell; but omit the "where" part. -- 1.7.10.4