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.

diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 4563714..8e92adc 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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.
 <programlisting>
   data R (x :: * -&#62; *) y
 </programlisting>
+You cannot use <literal>deriving</literal> on a data type declaration; write in
+<literal>instance</literal> declaration instead.
 </para></listitem>
 <listitem><para> 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.
 </para></listitem>
-<listitem><para> 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.
+<listitem><para> You can include instance declarations just as in Haskell; but omit the "where" part.
  </para></listitem>
 </itemizedlist>
 </para>