Refactor the extra-deps stuff for hs-boot

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

No change in behaviour

6 files changed, 77 insertions, 46 deletions

diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs
index ab476dbc9b..ac2071f6b6 100644
--- a/compiler/basicTypes/Name.hs
+++ b/compiler/basicTypes/Name.hs
@@ -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)
 
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 36534cecaf..5b250c645f 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -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
 
diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs
index f6296d16bd..930cea3ff3 100644
--- a/compiler/rename/RnSplice.hs
+++ b/compiler/rename/RnSplice.hs
@@ -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) $$
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 69bb795c86..e4fb33e3a4 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -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
 
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 1fb7662b59..dca128e201 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -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
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 23d0635868..59a4e0ddfb 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -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