Commit dfcf8852 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

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.
parent 4bcaad0c
......@@ -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
......@@ -756,6 +761,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)
......
......@@ -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
......
......@@ -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
......@@ -540,36 +551,10 @@ checkHiBootIface
boot_inst_ty = idType boot_dfun
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)
......
......@@ -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}
......@@ -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>
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment