Commit 9c9e9739 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Refactor the extra-deps stuff for hs-boot

See Note [Extra dependencies from .hs-boot files] in RnSource

No change in behaviour
parent 9987c66d
......@@ -61,7 +61,8 @@ module Name (
isValName, isVarName,
isWiredInName, isBuiltInSyntax,
wiredInNameTyThing_maybe,
nameIsLocalOrFrom, stableNameCmp,
nameIsLocalOrFrom, nameIsHomePackageImport,
stableNameCmp,
-- * Class 'NamedThing' and overloaded friends
NamedThing(..),
......@@ -244,6 +245,17 @@ nameIsLocalOrFrom from name
| Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod
| otherwise = True
nameIsHomePackageImport :: Module -> Name -> Bool
-- True if the Name is defined in module of this package
-- /other than/ the this_mod
nameIsHomePackageImport this_mod
= \nm -> case nameModule_maybe nm of
Nothing -> False
Just nm_mod -> nm_mod /= this_mod
&& modulePackageKey nm_mod == this_pkg
where
this_pkg = modulePackageKey this_mod
isTyVarName :: Name -> Bool
isTyVarName name = isTvOcc (nameOccName name)
......
......@@ -7,7 +7,7 @@
{-# LANGUAGE CPP, ScopedTypeVariables #-}
module RnSource (
rnSrcDecls, addTcgDUs, rnTyClDecls, findSplice
rnSrcDecls, addTcgDUs, findSplice
) where
#include "HsVersions.h"
......@@ -47,10 +47,10 @@ import Util ( mapSnd )
import Control.Monad
import Data.List( partition, sortBy )
import Maybes( orElse, mapMaybe )
#if __GLASGOW_HASKELL__ < 709
import Data.Traversable (traverse)
#endif
import Maybes( orElse, mapMaybe )
{-
@rnSourceDecl@ `renames' declarations.
......@@ -71,7 +71,7 @@ Checks the @(..)@ etc constraints in the export list.
-- Brings the binders of the group into scope in the appropriate places;
-- does NOT assume that anything is in scope already
rnSrcDecls :: [Name] -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
rnSrcDecls :: Maybe FreeVars -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
-- Rename a top-level HsGroup; used for normal source files *and* hs-boot files
rnSrcDecls extra_deps group@(HsGroup { hs_valds = val_decls,
hs_splcds = splice_decls,
......@@ -905,51 +905,64 @@ Note [Extra dependencies from .hs-boot files]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following case:
A.hs-boot
module A where
import B
data A1 = A1 B1
data A1
B.hs
module B where
import {-# SOURCE #-} A
type DisguisedA1 = A1
data B1 = B1 DisguisedA1
We do not follow type synonyms when building the dependencies for each datatype,
so we will not find out that B1 really depends on A1 (which means it depends on
itself). To handle this problem, at the moment we add dependencies to everything
that comes from an .hs-boot file. But we don't add those dependencies to
everything. Imagine module B above had another datatype declaration:
A.hs
module A where
import B
data A2 = A2 A1
data A1 = A1 B1
Here A1 is really recursive (via B1), but we won't see that easily when
doing dependency analysis when compiling A.hs
To handle this problem, we add a dependency
- from every local declaration
- to everything that comes from this module's .hs-boot file.
In this case, we'll add and edges
- from A2 to A1 (but that edge is there already)
- from A1 to A1 (which is new)
data B2 = B2 Int
Well, not quite *every* declaration. Imagine module A
above had another datatype declaration:
Even though B2 has a dependency (on Int), all its dependencies are from things
data A3 = A3 Int
Even though A3 has a dependency (on Int), all its dependencies are from things
that live on other packages. Since we don't have mutual dependencies across
packages, it is safe not to add the dependencies on the .hs-boot stuff to B2.
packages, it is safe not to add the dependencies on the .hs-boot stuff to A2.
Hence function Name.thisPackageImport.
See also Note [Grouping of type and class declarations] in TcTyClsDecls.
-}
isInPackage :: PackageKey -> Name -> Bool
isInPackage pkgId nm = case nameModule_maybe nm of
Nothing -> False
Just m -> pkgId == modulePackageKey m
-- We use nameModule_maybe because we might be in a TH splice, in which case
-- there is no module name. In that case we cannot have mutual dependencies,
-- so it's fine to return False here.
rnTyClDecls :: [Name] -> [TyClGroup RdrName]
rnTyClDecls :: Maybe FreeVars -> [TyClGroup RdrName]
-> RnM ([TyClGroup Name], FreeVars)
-- Rename the declarations and do depedency analysis on them
rnTyClDecls extra_deps tycl_ds
= do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupConcat tycl_ds)
; role_annot_env <- rnRoleAnnots (concatMap group_roles tycl_ds)
; thisPkg <- fmap thisPackage getDynFlags
; this_mod <- getModule
; let add_boot_deps :: FreeVars -> FreeVars
-- See Note [Extra dependencies from .hs-boot files]
add_boot_deps fvs | any (isInPackage thisPkg) (nameSetElems fvs)
= fvs `plusFV` mkFVs extra_deps
| otherwise
= fvs
add_boot_deps fvs
| Just extra <- extra_deps
, has_local_imports fvs = fvs `plusFV` extra
| otherwise = fvs
has_local_imports fvs
= foldNameSet ((||) . nameIsHomePackageImport this_mod)
False fvs
ds_w_fvs' = mapSnd add_boot_deps ds_w_fvs
......
......@@ -453,9 +453,7 @@ rn_bracket _ (DecBrL decls)
-- The emptyDUs is so that we just collect uses for this
-- group alone in the call to rnSrcDecls below
; (tcg_env, group') <- setGblEnv new_gbl_env $
rnSrcDecls [] group
-- The empty list is for extra dependencies coming from .hs-boot files
-- See Note [Extra dependencies from .hs-boot files] in RnSource
rnSrcDecls Nothing group
-- Discard the tcg_env; it contains only extra info about fixity
; traceRn (text "rn_bracket dec" <+> (ppr (tcg_dus tcg_env) $$
......
......@@ -36,6 +36,7 @@ import TcRnMonad
import PrelNames
import TypeRep -- We can see the representation of types
import TcType
import RdrName ( RdrName, rdrNameOcc )
import TcMType ( defaultKindVarToStar, zonkQuantifiedTyVar, writeMetaTyVar )
import TcEvidence
import Coercion
......@@ -298,7 +299,9 @@ zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
zonkTopLExpr e = zonkLExpr emptyZonkEnv e
zonkTopDecls :: Bag EvBind
-> LHsBinds TcId -> Bag OccName -> NameSet
-> LHsBinds TcId
-> Maybe (Located [LIE RdrName])
-> NameSet
-> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId]
-> TcM ([Id],
Bag EvBind,
......@@ -307,15 +310,18 @@ zonkTopDecls :: Bag EvBind
[LTcSpecPrag],
[LRuleDecl Id],
[LVectDecl Id])
zonkTopDecls ev_binds binds exports sig_ns rules vects imp_specs fords
zonkTopDecls ev_binds binds export_ies sig_ns rules vects imp_specs fords
= do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
-- Warn about missing signatures
-- Do this only when we we have a type to offer
; warn_missing_sigs <- woptM Opt_WarnMissingSigs
; warn_only_exported <- woptM Opt_WarnMissingExportedSigs
; let sig_warn
| warn_only_exported = topSigWarnIfExported exports sig_ns
; let export_occs = maybe emptyBag
(listToBag . map (rdrNameOcc . ieName . unLoc) . unLoc)
export_ies
sig_warn
| warn_only_exported = topSigWarnIfExported export_occs sig_ns
| warn_missing_sigs = topSigWarn sig_ns
| otherwise = noSigWarn
......
......@@ -318,19 +318,13 @@ tcRnModuleTcRnM hsc_env hsc_src
-- look for a hi-boot file
boot_iface <- tcHiBootIface hsc_src this_mod ;
let { exports_occs =
maybe emptyBag
(listToBag . map (rdrNameOcc . ieName . unLoc) . unLoc)
export_ies
} ;
-- Rename and type check the declarations
traceRn (text "rn1a") ;
tcg_env <- if isHsBootOrSig hsc_src then
tcRnHsBootDecls hsc_src local_decls
else
{-# SCC "tcRnSrcDecls" #-}
tcRnSrcDecls boot_iface exports_occs local_decls ;
tcRnSrcDecls boot_iface export_ies local_decls ;
setGblEnv tcg_env $ do {
-- Process the export list
......@@ -465,7 +459,10 @@ tcRnImports hsc_env import_decls
************************************************************************
-}
tcRnSrcDecls :: ModDetails -> Bag OccName -> [LHsDecl RdrName] -> TcM TcGblEnv
tcRnSrcDecls :: ModDetails
-> Maybe (Located [LIE RdrName]) -- Exports
-> [LHsDecl RdrName] -- Declarations
-> TcM TcGblEnv
-- Returns the variables free in the decls
-- Reason: solely to report unused imports and bindings
tcRnSrcDecls boot_iface exports decls
......@@ -541,7 +538,10 @@ tc_rn_src_decls boot_details ds
-- The extra_deps are needed while renaming type and class declarations
-- See Note [Extra dependencies from .hs-boot files] in RnSource
; let { extra_deps = map tyConName (typeEnvTyCons (md_types boot_details)) }
; let { tycons = typeEnvTyCons (md_types boot_details)
; extra_deps | null tycons = Nothing
| otherwise = Just (mkFVs (map tyConName tycons)) }
-- Deal with decls up to, but not including, the first splice
; (tcg_env, rn_decls) <- rnTopSrcDecls extra_deps first_group
-- rnTopSrcDecls fails if there are any errors
......@@ -639,7 +639,7 @@ tcRnHsBootDecls hsc_src decls
hs_ruleds = rule_decls,
hs_vects = vect_decls,
hs_annds = _,
hs_valds = val_binds }) <- rnTopSrcDecls [] first_group
hs_valds = val_binds }) <- rnTopSrcDecls Nothing first_group
-- The empty list is for extra dependencies coming from .hs-boot files
-- See Note [Extra dependencies from .hs-boot files] in RnSource
; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {
......@@ -1077,7 +1077,7 @@ instMisMatch is_boot inst
************************************************************************
-}
rnTopSrcDecls :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
rnTopSrcDecls :: Maybe FreeVars -> HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
-- Fails if there are any errors
rnTopSrcDecls extra_deps group
= do { -- Rename the source decls
......@@ -1875,7 +1875,7 @@ tcRnDeclsi hsc_env local_decls =
all_ev_binds = cur_ev_binds `unionBags` new_ev_binds
(bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
<- zonkTopDecls all_ev_binds binds emptyBag sig_ns rules vects
<- zonkTopDecls all_ev_binds binds Nothing sig_ns rules vects
imp_specs fords
let --global_ids = map globaliseAndTidyId bind_ids
......
......@@ -432,6 +432,8 @@ data TcGblEnv
-- initially in un-zonked form and are finally zonked in tcRnSrcDecls
tcg_rn_exports :: Maybe [Located (IE Name)],
-- Nothing <=> no explicit export list
tcg_rn_imports :: [LImportDecl Name],
-- Keep the renamed imports regardless. They are not
-- voluminous and are needed if you want to report unused imports
......
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