Commit 5f9c6d2a authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Support for using only partial pieces of included signatures.



Summary:
Generally speaking, it's not possible to "hide" a requirement from a
package you include, because if there is some module relying on that
requirement, well, you can't just wish it out of existence.

However, some packages don't have any modules.  For these, we can
validly thin out requirements; indeed, this is very convenient if
someone has published a large signature package but you only want
some of the definitions.

This patchset tweaks the interpretation of export lists in
signatures: in particular, they no longer need to refer to
entities that are defined locally; they range over both the current
signature as well as any signatures that were inherited from
signature packages (defined by having zero exposed modules.)

In the process of doing this, I cleaned up a number of other
things:

* rnModIface and rnModExports now report errors that occurred
  during renaming and can propagate these to the TcM monad.
  This is important because in the current semantics, you can
  thin out a type which is referenced by a value you keep;
  in this situation, we need to error (to ensure that all
  types in signatures are rooted, so that we can determine
  their identities).

* I ended up introducing a new construct 'dependency signature;
  to bkp files, to make it easier to tell if we were depending
  on a signature package.  It's not difficult for Cabal to
  figure this out (I already have a patch for it.)
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: simonpj, austin, bgamari

Subscribers: thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D2904

GHC Trac Issues: #12994
parent 436aa7aa
......@@ -68,7 +68,12 @@ type LHsUnitDecl n = Located (HsUnitDecl n)
-- | An include of another unit
data IncludeDecl n = IncludeDecl {
idUnitId :: LHsUnitId n,
idModRenaming :: Maybe [ LRenaming ]
idModRenaming :: Maybe [ LRenaming ],
-- | Is this a @dependency signature@ include? If so,
-- we don't compile this include when we instantiate this
-- unit (as there should not be any modules brought into
-- scope.)
idSignatureInclude :: Bool
}
-- | Rename a module from one name to another. The identity renaming
......
......@@ -104,11 +104,20 @@ computeUnitId (L _ unit) = (cid, [ (r, mkHoleModule r) | r <- reqs ])
reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit)))
get_reqs (DeclD SignatureD (L _ modname) _) = unitUniqDSet modname
get_reqs (DeclD ModuleD _ _) = emptyUniqDSet
get_reqs (IncludeD (IncludeDecl (L _ hsuid) _)) =
get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) =
unitIdFreeHoles (convertHsUnitId hsuid)
-- | Tiny enum for all types of Backpack operations we may do.
data SessionType = ExeSession | TcSession | CompSession
data SessionType
-- | A compilation operation which will result in a
-- runnable executable being produced.
= ExeSession
-- | A type-checking operation which produces only
-- interface files, no object files.
| TcSession
-- | A compilation operation which produces both
-- interface files and object files.
| CompSession
deriving (Eq)
-- | Create a temporary Session to do some sort of type checking or
......@@ -208,11 +217,19 @@ compileUnit cid insts = do
lunit <- getSource cid
buildUnit CompSession cid insts lunit
-- Invariant: this NEVER returns InstalledUnitId
hsunitDeps :: HsUnit HsComponentId -> [(UnitId, ModRenaming)]
hsunitDeps unit = concatMap get_dep (hsunitBody unit)
-- | Compute the dependencies with instantiations of a syntactic
-- HsUnit; e.g., wherever you see @dependency p[A=<A>]@ in a
-- unit file, return the 'UnitId' corresponding to @p[A=<A>]@.
-- The @include_sigs@ parameter controls whether or not we also
-- include @dependency signature@ declarations in this calculation.
--
-- Invariant: this NEVER returns InstalledUnitId.
hsunitDeps :: Bool {- include sigs -} -> HsUnit HsComponentId -> [(UnitId, ModRenaming)]
hsunitDeps include_sigs unit = concatMap get_dep (hsunitBody unit)
where
get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn))) = [(convertHsUnitId hsuid, go mb_lrn)]
get_dep (L _ (IncludeD (IncludeDecl (L _ hsuid) mb_lrn is_sig)))
| include_sigs || not is_sig = [(convertHsUnitId hsuid, go mb_lrn)]
| otherwise = []
where
go Nothing = ModRenaming True []
go (Just lrns) = ModRenaming False (map convRn lrns)
......@@ -223,7 +240,11 @@ hsunitDeps unit = concatMap get_dep (hsunitBody unit)
buildUnit :: SessionType -> ComponentId -> [(ModuleName, Module)] -> LHsUnit HsComponentId -> BkpM ()
buildUnit session cid insts lunit = do
let deps_w_rns = hsunitDeps (unLoc lunit)
-- NB: include signature dependencies ONLY when typechecking.
-- If we're compiling, it's not necessary to recursively
-- compile a signature since it isn't going to produce
-- any object files.
let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit)
raw_deps = map fst deps_w_rns
dflags <- getDynFlags
-- The compilation dependencies are just the appropriately filled
......@@ -273,11 +294,7 @@ buildUnit session cid insts lunit = do
obj_files = concatMap getOfiles linkables
let compat_fs = (case cid of ComponentId fs -> fs)
cand_compat_pn = PackageName compat_fs
compat_pn = case session of
TcSession -> cand_compat_pn
_ | [] <- insts -> cand_compat_pn
| otherwise -> PackageName compat_fs
compat_pn = PackageName compat_fs
return InstalledPackageInfo {
-- Stub data
......@@ -336,7 +353,7 @@ buildUnit session cid insts lunit = do
compileExe :: LHsUnit HsComponentId -> BkpM ()
compileExe lunit = do
msgUnitId mainUnitId
let deps_w_rns = hsunitDeps (unLoc lunit)
let deps_w_rns = hsunitDeps False (unLoc lunit)
deps = map fst deps_w_rns
-- no renaming necessary
forM_ (zip [1..] deps) $ \(i, dep) ->
......@@ -562,7 +579,8 @@ renameHsUnits dflags m units = map (fmap renameHsUnit) units
renameHsUnitDecl (IncludeD idecl) =
IncludeD IncludeDecl {
idUnitId = fmap renameHsUnitId (idUnitId idecl),
idModRenaming = idModRenaming idecl
idModRenaming = idModRenaming idecl,
idSignatureInclude = idSignatureInclude idecl
}
renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId
......@@ -713,7 +731,9 @@ hsModuleToModSummary :: PackageName
-> Located (HsModule RdrName)
-> BkpM ModSummary
hsModuleToModSummary pn hsc_src modname
hsmod@(L loc (HsModule _ _ imps _ _ _)) = do
hsmod = do
let imps = hsmodImports (unLoc hsmod)
loc = getLoc hsmod
hsc_env <- getSession
-- Sort of the same deal as in DriverPipeline's getLocation
-- Use the PACKAGE NAME to find the location
......
......@@ -7,6 +7,7 @@ module NameShape(
extendNameShape,
nameShapeExports,
substNameShape,
maybeSubstNameShape,
) where
#include "HsVersions.h"
......@@ -134,6 +135,15 @@ substNameShape ns n | nameModule n == ns_module ns
| otherwise
= n
-- | Like 'substNameShape', but returns @Nothing@ if no substitution
-- works.
maybeSubstNameShape :: NameShape -> Name -> Maybe Name
maybeSubstNameShape ns n
| nameModule n == ns_module ns
= lookupOccEnv (ns_map ns) (occName n)
| otherwise
= Nothing
-- | The 'Module' of any 'Name's a 'NameShape' has action over.
ns_module :: NameShape -> Module
ns_module = mkHoleModule . ns_mod_name
......
......@@ -9,10 +9,13 @@
module RnModIface(
rnModIface,
rnModExports,
tcRnModIface,
tcRnModExports,
) where
#include "HsVersions.h"
import SrcLoc
import Outputable
import HscTypes
import Module
......@@ -21,6 +24,7 @@ import Avail
import IfaceSyn
import FieldLabel
import Var
import ErrUtils
import Name
import TcRnMonad
......@@ -34,9 +38,39 @@ import DynFlags
import qualified Data.Traversable as T
import Bag
import Data.IORef
import NameShape
import IfaceEnv
tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a
tcRnMsgMaybe do_this = do
r <- liftIO $ do_this
case r of
Left errs -> do
addMessages (emptyBag, errs)
failM
Right x -> return x
tcRnModIface :: [(ModuleName, Module)] -> Maybe NameShape -> ModIface -> TcM ModIface
tcRnModIface x y z = do
hsc_env <- getTopEnv
tcRnMsgMaybe $ rnModIface hsc_env x y z
tcRnModExports :: [(ModuleName, Module)] -> ModIface -> TcM [AvailInfo]
tcRnModExports x y = do
hsc_env <- getTopEnv
tcRnMsgMaybe $ rnModExports hsc_env x y
failWithRn :: SDoc -> ShIfM a
failWithRn doc = do
errs_var <- fmap sh_if_errs getGblEnv
dflags <- getDynFlags
errs <- readTcRef errs_var
-- TODO: maybe associate this with a source location?
writeTcRef errs_var (errs `snocBag` mkPlainErrMsg dflags noSrcSpan doc)
failM
-- | What we have a generalized ModIface, which corresponds to
-- a module that looks like p[A=<A>]:B. We need a *specific* ModIface, e.g.
-- p[A=q():A]:B (or maybe even p[A=<B>]:B) which we load
......@@ -58,7 +92,7 @@ import IfaceEnv
-- should be Foo.T; then we'll also rename this (this is used
-- when loading an interface to merge it into a requirement.)
rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape
-> ModIface -> IO ModIface
-> ModIface -> IO (Either ErrorMessages ModIface)
rnModIface hsc_env insts nsubst iface = do
initRnIface hsc_env iface insts nsubst $ do
mod <- rnModule (mi_module iface)
......@@ -81,7 +115,7 @@ rnModIface hsc_env insts nsubst iface = do
-- | Rename just the exports of a 'ModIface'. Useful when we're doing
-- shaping prior to signature merging.
rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO [AvailInfo]
rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either ErrorMessages [AvailInfo])
rnModExports hsc_env insts iface
= initRnIface hsc_env iface insts Nothing
$ mapM rnAvailInfo (mi_exports iface)
......@@ -94,19 +128,28 @@ rnModExports hsc_env insts iface
************************************************************************
-}
-- | Initialize the 'ShIfM' monad.
-- | Run a computation in the 'ShIfM' monad.
initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape
-> ShIfM a -> IO a
initRnIface hsc_env iface insts nsubst do_this =
let hsubst = listToUFM insts
rn_mod = renameHoleModule (hsc_dflags hsc_env) hsubst
-> ShIfM a -> IO (Either ErrorMessages a)
initRnIface hsc_env iface insts nsubst do_this = do
errs_var <- newIORef emptyBag
let dflags = hsc_dflags hsc_env
hsubst = listToUFM insts
rn_mod = renameHoleModule dflags hsubst
env = ShIfEnv {
sh_if_module = rn_mod (mi_module iface),
sh_if_semantic_module = rn_mod (mi_semantic_module iface),
sh_if_hole_subst = listToUFM insts,
sh_if_shape = nsubst
sh_if_shape = nsubst,
sh_if_errs = errs_var
}
in initTcRnIf 'c' hsc_env env () do_this
-- Modeled off of 'initTc'
res <- initTcRnIf 'c' hsc_env env () $ tryM do_this
msgs <- readIORef errs_var
case res of
Left _ -> return (Left msgs)
Right r | not (isEmptyBag msgs) -> return (Left msgs)
| otherwise -> return (Right r)
-- | Environment for 'ShIfM' monads.
data ShIfEnv = ShIfEnv {
......@@ -123,7 +166,9 @@ data ShIfEnv = ShIfEnv {
-- the names in the interface. If this is 'Nothing', then
-- we just load the target interface and look at the export
-- list to determine the renaming.
sh_if_shape :: Maybe NameShape
sh_if_shape :: Maybe NameShape,
-- Mutable reference to keep track of errors (similar to 'tcl_errs')
sh_if_errs :: IORef ErrorMessages
}
getHoleSubst :: ShIfM ShHoleSubst
......@@ -215,10 +260,21 @@ rnIfaceGlobal n = do
, isHoleModule m'
-- NB: this could be Nothing for computeExports, we have
-- nothing to say.
-> do fmap (case mb_nsubst of
Nothing -> id
Just nsubst -> substNameShape nsubst)
$ setNameModule (Just m') n
-> do n' <- setNameModule (Just m') n
case mb_nsubst of
Nothing -> return n'
Just nsubst ->
case maybeSubstNameShape nsubst n' of
-- TODO: would love to have context
-- TODO: This will give an unpleasant message if n'
-- is a constructor; then we'll suggest adding T
-- but it won't work.
Nothing -> failWithRn $ vcat [
text "The identifier" <+> ppr (occName n') <+>
text "does not exist in the local signature.",
parens (text "Try adding it to the export list of the hsig file.")
]
Just n'' -> return n''
-- Fastpath: we are renaming p[H=<H>]:A.T, in which case the
-- export list is irrelevant.
| not (isHoleModule m)
......@@ -239,7 +295,14 @@ rnIfaceGlobal n = do
iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env
$ loadSysInterface (text "rnIfaceGlobal") m''
let nsubst = mkNameShape (moduleName m) (mi_exports iface)
return (substNameShape nsubst n)
case maybeSubstNameShape nsubst n of
Nothing -> failWithRn $ vcat [
text "The identifier" <+> ppr (occName n) <+>
-- NB: report m' because it's more user-friendly
text "does not exist in the signature for" <+> ppr m',
parens (text "Try adding it to the export list in that hsig file.")
]
Just n' -> return n'
-- | Rename a DFun name. Here is where we ensure that DFuns have the correct
-- module as described in Note [Bogus DFun renamings].
......
......@@ -75,6 +75,7 @@ import RnModIface
import UniqDSet
import Control.Monad
import Control.Exception
import Data.IORef
import System.FilePath
......@@ -540,8 +541,12 @@ computeInterface doc_str hi_boot_file mod0 = do
case r of
Succeeded (iface0, path) -> do
hsc_env <- getTopEnv
r <- liftIO (rnModIface hsc_env (indefUnitIdInsts (indefModuleUnitId indef)) Nothing iface0)
return (Succeeded (r, path))
r <- liftIO $
rnModIface hsc_env (indefUnitIdInsts (indefModuleUnitId indef))
Nothing iface0
case r of
Right x -> return (Succeeded (x, path))
Left errs -> liftIO . throwIO . mkSrcErr $ errs
Failed err -> return (Failed err)
(mod, _) ->
findAndReadIface doc_str mod hi_boot_file
......
......@@ -74,8 +74,10 @@ getImports dflags buf filename source_filename = do
then throwIO $ mkSrcErr errs
else
case rdr_module of
L _ (HsModule mb_mod _ imps _ _ _) ->
L _ hsmod ->
let
mb_mod = hsmodName hsmod
imps = hsmodImports hsmod
main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename) 1 1)
mod = mb_mod `orElse` L main_loc mAIN_NAME
(src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
......
......@@ -414,7 +414,7 @@ hscTypecheck keep_rn mod_summary mb_rdr_module = do
if hsc_src == HsigFile
then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing
ioMsgMaybe $
tcRnMergeSignatures hsc_env (tcg_top_loc tc_result0) iface
tcRnMergeSignatures hsc_env (tcg_top_loc tc_result0) hpm iface
else return tc_result0
-- wrapper around tcRnModule to handle safe haskell extras
......
......@@ -643,7 +643,12 @@ unitdecl :: { LHsUnitDecl PackageName }
{ sL1 $2 $ DeclD SignatureD $3 Nothing }
| 'dependency' unitid mayberns
{ sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2
, idModRenaming = $3 }) }
, idModRenaming = $3
, idSignatureInclude = False }) }
| 'dependency' 'signature' unitid
{ sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $3
, idModRenaming = Nothing
, idSignatureInclude = True }) }
-----------------------------------------------------------------------------
-- Module Header
......
......@@ -17,6 +17,7 @@ module TcBackpack (
) where
import Packages
import TcRnExports
import DynFlags
import HsSyn
import RdrName
......@@ -46,6 +47,7 @@ import FastString
import Maybes
import TcEnv
import Var
import IfaceSyn
import PrelNames
import qualified Data.Map as Map
......@@ -311,18 +313,42 @@ tcRnCheckUnitId hsc_env uid =
-- | Top-level driver for signature merging (run after typechecking
-- an @hsig@ file).
tcRnMergeSignatures :: HscEnv -> RealSrcSpan -> ModIface
tcRnMergeSignatures :: HscEnv -> RealSrcSpan -> HsParsedModule -> ModIface
-> IO (Messages, Maybe TcGblEnv)
tcRnMergeSignatures hsc_env real_loc iface =
tcRnMergeSignatures hsc_env real_loc hsmod iface =
withTiming (pure dflags)
(text "Signature merging" <+> brackets (ppr this_mod))
(const ()) $
initTc hsc_env HsigFile False this_mod real_loc $
mergeSignatures iface
mergeSignatures hsmod iface
where
dflags = hsc_dflags hsc_env
this_mod = mi_module iface
thinModIface :: [AvailInfo] -> ModIface -> ModIface
thinModIface avails iface =
iface {
mi_exports = avails,
-- mi_fixities = ...,
-- mi_warns = ...,
-- mi_anns = ...,
-- TODO: The use of nameOccName here is a bit dodgy, because
-- perhaps there might be two IfaceTopBndr that are the same
-- OccName but different Name. Requires better understanding
-- of invariants here.
mi_decls = filter (decl_pred . snd) (mi_decls iface)
-- mi_insts = ...,
-- mi_fam_insts = ...,
}
where
occs = mkOccSet [ occName n
| a <- avails
, n <- availNames a ]
-- NB: Never drop DFuns
decl_pred IfaceId{ ifIdDetails = IfDFunId } = True
decl_pred decl =
nameOccName (ifName decl) `elemOccSet` occs
-- Note [Blank hsigs for all requirements]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- One invariant that a client of GHC must uphold is that there
......@@ -336,8 +362,8 @@ tcRnMergeSignatures hsc_env real_loc iface =
-- from 'requirementMerges' into this signature, producing
-- a final 'TcGblEnv' that matches the local signature and
-- all required signatures.
mergeSignatures :: ModIface -> TcRn TcGblEnv
mergeSignatures lcl_iface0 = do
mergeSignatures :: HsParsedModule -> ModIface -> TcRn TcGblEnv
mergeSignatures hsmod lcl_iface0 = do
-- The lcl_iface0 is the ModIface for the local hsig
-- file, which is guaranteed to exist, see
-- Note [Blank hsigs for all requirements]
......@@ -346,41 +372,68 @@ mergeSignatures lcl_iface0 = do
tcg_env <- getGblEnv
let outer_mod = tcg_mod tcg_env
inner_mod = tcg_semantic_mod tcg_env
mb_exports = hsmodExports (unLoc (hpm_module hsmod))
-- STEP 1: Figure out all of the external signature interfaces
-- we are going to merge in.
let reqs = requirementMerges dflags (moduleName (tcg_mod tcg_env))
-- STEP 2: Read in the RAW forms of all of these interfaces
ireq_ifaces <- forM reqs $ \(IndefModule iuid mod_name) ->
ireq_ifaces0 <- forM reqs $ \(IndefModule iuid mod_name) ->
fmap fst
. withException
. flip (findAndReadIface (text "mergeSignatures")) False
$ fst (splitModuleInsts (mkModule (IndefiniteUnitId iuid) mod_name))
-- STEP 3: Get the unrenamed exports of all these interfaces, and
-- dO shaping on them.
-- do shaping on them.
let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as
gen_subst nsubst ((IndefModule iuid _), ireq_iface) = do
gen_subst (nsubst,ifaces) (imod@(IndefModule iuid _), ireq_iface) = do
let insts = indefUnitIdInsts iuid
as1 <- liftIO $ rnModExports hsc_env insts ireq_iface
mb_r <- extend_ns nsubst as1
as1 <- tcRnModExports insts ireq_iface
let inst_uid = fst (splitUnitIdInsts (IndefiniteUnitId iuid))
pkg = getInstalledPackageDetails dflags inst_uid
rdr_env = mkGlobalRdrEnv (gresFromAvails Nothing as1)
(thinned_iface, as2) <- case mb_exports of
Just (L loc _)
| null (exposedModules pkg) -> setSrcSpan loc $ do
-- Suppress missing errors; we'll pick em up
-- when we test exports on the final thing
(msgs, mb_r) <- tryTc $
setGblEnv tcg_env {
tcg_rdr_env = rdr_env
} $ exports_from_avail mb_exports rdr_env
(tcg_imports tcg_env) (tcg_semantic_mod tcg_env)
case mb_r of
Just (_, as2) -> return (thinModIface as2 ireq_iface, as2)
Nothing -> addMessages msgs >> failM
_ -> return (ireq_iface, as1)
mb_r <- extend_ns nsubst as2
case mb_r of
Left err -> failWithTc err
Right nsubst' -> return nsubst'
Right nsubst' -> return (nsubst',(imod, thinned_iface):ifaces)
nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0)
nsubst <- foldM gen_subst nsubst0 (zip reqs ireq_ifaces)
let exports = nameShapeExports nsubst
tcg_env <- return tcg_env {
tcg_rdr_env = mkGlobalRdrEnv (gresFromAvails Nothing exports),
(nsubst, rev_thinned_ifaces) <- foldM gen_subst (nsubst0, []) (zip reqs ireq_ifaces0)
let thinned_ifaces = reverse rev_thinned_ifaces
exports = nameShapeExports nsubst
rdr_env = mkGlobalRdrEnv (gresFromAvails Nothing exports)
setGblEnv tcg_env {
tcg_rdr_env = rdr_env,
tcg_exports = exports,
tcg_dus = usesOnly (availsToNameSetWithSelectors exports)
}
} $ do
tcg_env <- getGblEnv
-- Make sure we didn't refer to anything that doesn't actually exist
_ <- exports_from_avail mb_exports rdr_env
(tcg_imports tcg_env) (tcg_semantic_mod tcg_env)
failIfErrsM
-- STEP 4: Rename the interfaces
ext_ifaces <- forM (zip reqs ireq_ifaces) $ \((IndefModule iuid _), ireq_iface) ->
liftIO (rnModIface hsc_env (indefUnitIdInsts iuid) (Just nsubst) ireq_iface)
lcl_iface <- liftIO $ rnModIface hsc_env (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0
ext_ifaces <- forM thinned_ifaces $ \((IndefModule iuid _), ireq_iface) ->
tcRnModIface (indefUnitIdInsts iuid) (Just nsubst) ireq_iface
lcl_iface <- tcRnModIface (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0
let ifaces = lcl_iface : ext_ifaces
-- STEP 5: Typecheck the interfaces
......@@ -591,8 +644,7 @@ checkImplements impl_mod (IndefModule uid mod_name) = do
failIfErrsM
-- STEP 4: Now that the export is complete, rename the interface...
hsc_env <- getTopEnv
sig_iface <- liftIO $ rnModIface hsc_env insts (Just nsubst) isig_iface
sig_iface <- tcRnModIface insts (Just nsubst) isig_iface
-- STEP 5: ...and typecheck it. (Note that in both cases, the nsubst
-- lets us determine how top-level identifiers should be handled.)
......
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
module TcRnExports (tcRnExports) where
module TcRnExports (tcRnExports, exports_from_avail) where
import HsSyn
import PrelNames
......@@ -115,7 +115,8 @@ tcRnExports :: Bool -- False => no 'module M(..) where' header at all
tcRnExports explicit_mod exports
tcg_env@TcGblEnv { tcg_mod = this_mod,
tcg_rdr_env = rdr_env,
tcg_imports = imports }
tcg_imports = imports,
tcg_src = hsc_src }
= unsetWOptM Opt_WarnWarningsDeprecations $
-- Do not report deprecations arising from the export
-- list, to avoid bleating about re-exporting a deprecated
......@@ -136,8 +137,14 @@ tcRnExports explicit_mod exports
-- ToDo: the 'noLoc' here is unhelpful if 'main'
-- turns out to be out of scope
; let do_it = exports_from_avail real_exports rdr_env imports this_mod
; (rn_exports, final_avails)
<- exports_from_avail real_exports rdr_env imports this_mod
<- if hsc_src == HsigFile
then do (msgs, mb_r) <- tryTc do_it
case mb_r of
Just r -> return r
Nothing -> addMessages msgs >> failM
else checkNoErrs $ do_it
; let final_ns = availsToNameSetWithSelectors final_avails
; traceRn "rnExports: Exports:" (ppr final_avails)
......@@ -185,7 +192,7 @@ exports_from_avail Nothing rdr_env _imports _this_mod
exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
= do ExportAccum ie_names _ exports
<- checkNoErrs $ foldAndRecoverM do_litem emptyExportAccum rdr_items
<- foldAndRecoverM do_litem emptyExportAccum rdr_items
let final_exports = nubAvails exports -- Combine families
return (Just ie_names, final_exports)
where
......
unit h where
signature H(T) where
signature H where
data T
unit p where
dependency h[H=<H>]
module B(T(..)) where
data T = T
signature H(T(..), f) where
signature H(module H, T(..)) where
import B(T(..))
f :: a -> a
module A(T) where
......
......@@ -10,7 +10,7 @@ unit timpl where
unit q where
dependency timpl
dependency p[H=<H>,T=<T>]
signature T(T) where
signature T(module T, T) where
import TImpl
module A where
import H
......
......@@ -3,7 +3,7 @@ unit p where
data M = M
module M2 where
data M = M
signature A(M) where
signature A(module A, M) where