Hannes Siebenhandl pushed to branch wip/fendor/26300 at Glasgow Haskell Compiler / GHC

Commits:

16 changed files:

Changes:

  • compiler/GHC/Iface/Errors/Ppr.hs
    ... ... @@ -240,7 +240,9 @@ cantFindErrorX pkg_hidden_hint may_show_locations mod_or_interface (CantFindInst
    240 240 
           -> vcat (map pprMod mods)
    241 241 
           where
    242 242 
             unambiguousPackages = foldl' unambiguousPackage (Just []) mods
    243 
    -        unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)
    243 
    +        unambiguousPackage (Just xs) (m, ExternalUnitOrigin (ModOrigin (Just _) _ _ _))
    244 
    +            = Just (moduleUnit m : xs)
    245 
    +        unambiguousPackage (Just xs) (m, HomeOrigin{})
    244 246 
                 = Just (moduleUnit m : xs)
    245 247 
             unambiguousPackage _ _ = Nothing
    246 248 
         GenericMissing pkg_hiddens mod_hiddens unusables files ->
    ... ... @@ -251,9 +253,16 @@ cantFindErrorX pkg_hidden_hint may_show_locations mod_or_interface (CantFindInst
    251 253 
       where
    252 254 
         pprMod (m, o) = text "it is bound as" <+> ppr m <+>
    253 255 
                                     text "by" <+> pprOrigin m o
    254 
    -    pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"
    255 
    -    pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"
    256 
    -    pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (
    256 
    +
    257 
    +    pprOrigin m HomeOrigin = pprHomeOrigin m
    258 
    +    pprOrigin m (ExternalUnitOrigin o) = pprExtOrigin m o
    259 
    +
    260 
    +    pprHomeOrigin m =
    261 
    +      text "package" <+> ppr (moduleUnit m)
    262 
    +
    263 
    +    pprExtOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"
    264 
    +    pprExtOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"
    265 
    +    pprExtOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (
    257 266 
           if e == Just True
    258 267 
               then [text "package" <+> ppr (moduleUnit m)]
    259 268 
               else [] ++

  • compiler/GHC/Iface/Errors/Types.hs
    ... ... @@ -6,6 +6,7 @@ module GHC.Iface.Errors.Types (
    6 6 
       , ReadInterfaceError(..)
    7 7 
       , CantFindInstalled(..)
    8 8 
       , CantFindInstalledReason(..)
    9 
    +  , HomeOrExternalOrigin(..)
    9 10 
       , FindingModuleOrInterface(..)
    10 11
    11 12 
       , BuildingCabalPackage(..)
    ... ... @@ -75,9 +76,13 @@ data CantFindInstalledReason
    75 76 
       | GenericMissing
    76 77 
           [UnitInfo] [Unit]
    77 78 
           [UnusableUnit] [FilePath]
    78 
    -  | MultiplePackages [(Module, ModuleOrigin)]
    79 
    +  | MultiplePackages [(Module, HomeOrExternalOrigin)]
    79 80 
       deriving Generic
    80 81
    82 
    +data HomeOrExternalOrigin
    83 
    +  = HomeOrigin
    84 
    +  | ExternalUnitOrigin ModuleOrigin
    85 
    +
    81 86 
     data CantFindInstalled =
    82 87 
       CantFindInstalled ModuleName CantFindInstalledReason
    83 88 
       deriving Generic

  • compiler/GHC/Unit/Finder.hs
    ... ... @@ -78,10 +78,11 @@ import GHC.Types.Unique.Set
    78 78 
     import qualified Data.List as L(sort)
    79 79 
     import Data.List.NonEmpty ( NonEmpty (..) )
    80 80 
     import Data.Set (Set)
    81 
    -import qualified Data.Set as Set (empty, intersection, difference, null, toList)
    81 
    +import qualified Data.Set as Set (empty, intersection, difference, null, toList, member)
    82 82 
     import qualified System.Directory as SD
    83 83 
     import qualified System.OsPath as OsPath
    84 84 
     import qualified Data.List.NonEmpty as NE
    85 
    +import GHC.Iface.Errors.Types
    85 86
    86 87 
     type FileExt = OsString -- Filename extension
    87 88 
     type BaseName = OsPath  -- Basename of file
    ... ... @@ -247,8 +248,12 @@ findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit
    247 248 
                                  ue_findHomeUnitEnv home_unit_id ue
    248 249
    249 250 
         other_fopts :: [(UnitId, FinderOpts)]
    250 
    -    other_fopts = homeUnitDepsFinderOpts ue home_module_name_providers_map
    251 
    +    other_fopts =
    252 
    +      let
    253 
    +        (providers, others) = homeUnitDepsFinderOpts ue home_module_name_providers_map
    251 254 
                                              unit_state mod_name
    255 
    +      in
    256 
    +        providers ++ others
    252 257
    253 258 
     -- | Locate a plugin module requested by the user, for a compiler
    254 259 
     -- plugin.  This consults the same set of exposed packages as
    ... ... @@ -263,11 +268,17 @@ findPluginModuleNoHsc
    263 268 
       -> ModuleName
    264 269 
       -> IO FindResult
    265 270 
     findPluginModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit@(Just home_unit) mod_name =
    266 
    -    findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map
    267 
    -                            mb_home_unit mod_name
    271 
    +    home_import
    268 272 
         `orIfNotFound`
    269 
    -    findExposedPluginPackageModule fc fopts unit_state mod_name
    273 
    +      (findHomeModuleAmongDeps fc ue home_module_name_providers_map
    274 
    +                              mb_home_unit mod_name
    275 
    +      `combineFindResult`
    276 
    +      findExposedPluginPackageModule fc fopts unit_state mod_name
    277 
    +      )
    270 278 
       where
    279 
    +    home_import =
    280 
    +      findHomeModule fc fopts home_unit mod_name
    281 
    +
    271 282 
         unit_state = HUG.homeUnitEnv_units $
    272 283 
                      ue_findHomeUnitEnv (homeUnitId home_unit) ue
    273 284 
     findPluginModuleNoHsc fc fopts ue _ Nothing mod_name =
    ... ... @@ -291,9 +302,9 @@ findPluginModule hsc_env mod_name = do
    291 302 
     rankedHomeUnitDeps :: HomeModuleNameProvidersMap
    292 303 
                        -> ModuleName
    293 304 
                        -> Set UnitId
    294 
    -                   -> [UnitId]
    305 
    +                   -> ([UnitId], [UnitId])
    295 306 
     rankedHomeUnitDeps _ _ home_unit_deps | Set.null home_unit_deps
    296 
    -    = []
    307 
    +    = ([], [])
    297 308 
     -- The special handling of the situation where the dependency set is empty does
    298 309 
     -- not change the result, but it avoids triggering evaluation of the module
    299 310 
     -- graph. This is particularly important in one-shot mode, where the module
    ... ... @@ -309,7 +320,7 @@ rankedHomeUnitDeps _ _ home_unit_deps | Set.null home_unit_deps
    309 320 
     --     3 | import {-# source #-} A
    310 321 
     --       | ^^^^^^^^^^^^^^^^^^^^^^^
    311 322 
     rankedHomeUnitDeps home_module_name_providers_map mod_name home_unit_deps
    312 
    -    = Set.toList cached_deps ++ Set.toList uncached_deps
    323 
    +    = (Set.toList cached_deps, Set.toList uncached_deps)
    313 324 
         where
    314 325
    315 326 
         cached_providers :: Set UnitId
    ... ... @@ -330,12 +341,19 @@ homeUnitDepsFinderOpts
    330 341 
       -> HomeModuleNameProvidersMap
    331 342 
       -> UnitState  -- ^ unit state of the requesting home unit
    332 343 
       -> ModuleName
    333 
    -  -> [(UnitId, FinderOpts)]
    344 
    +  -> ([(UnitId, FinderOpts)], [(UnitId, FinderOpts)])
    334 345 
     homeUnitDepsFinderOpts ue home_module_name_providers_map unit_state mod_name =
    335 
    -    [ (uid, initFinderOpts (ue_unitFlags uid ue))
    336 
    -    | uid <- rankedHomeUnitDeps home_module_name_providers_map mod_name
    346 
    +  let
    347 
    +    (providers, otherHomeUnits) = rankedHomeUnitDeps home_module_name_providers_map mod_name
    337 348 
                                     (homeUnitDepends unit_state)
    338 
    -    ]
    349 
    +  in
    350 
    +    ( [ (uid, initFinderOpts (ue_unitFlags uid ue))
    351 
    +      | uid <- providers
    352 
    +      ]
    353 
    +    , [ (uid, initFinderOpts (ue_unitFlags uid ue))
    354 
    +      | uid <- otherHomeUnits
    355 
    +      ]
    356 
    +    )
    339 357
    340 358 
     -- | Search for @mod_name@ in the given home unit.
    341 359 
     findHomeUnitDepModule
    ... ... @@ -364,30 +382,29 @@ findHomeUnitDepModule fc ue home_module_name_providers_map mod_name (uid, opts)
    364 382 
     -- successful result.
    365 383 
     findHomeModuleAmongDeps
    366 384 
       :: FinderCache
    367 
    -  -> FinderOpts
    368 385 
       -> UnitEnv
    369 386 
       -> HomeModuleNameProvidersMap
    370 387 
       -> Maybe HomeUnit
    371 388 
       -> ModuleName
    372 389 
       -> IO FindResult
    373 
    -findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map mb_home_unit mod_name =
    374 
    -    foldr1 orIfNotFound (home_import :| map home_pkg_import other_fopts)
    375 
    -    -- Do not try to be smart and change this to `foldr orIfNotFound home_import
    376 
    -    -- (map home_pkg_import other_fopts)`, as that would not be the same.
    377 
    -    -- `home_import` is first because we need to first look within the current
    378 
    -    -- unit before looking at the other units in order.
    390 
    +findHomeModuleAmongDeps fc ue home_module_name_providers_map mb_home_unit mod_name =
    391 
    +  findInDirectDeps `orIfNotFound` findInOtherDeps
    379 392 
       where
    380 
    -    home_import = case mb_home_unit of
    381 
    -        Just home_unit -> findHomeModule fc fopts home_unit mod_name
    382 
    -        Nothing        -> pure $
    383 
    -                          NoPackage (panic "findHomeModuleAmongDeps: no home-unit")
    393 
    +    findInDirectDeps = case provider_fopts of
    394 
    +      p:ps -> foldr1 combineFindResult (home_pkg_import p :| map home_pkg_import ps)
    395 
    +      [] -> pure notFound
    396 
    +
    397 
    +    findInOtherDeps = case other_fopts of
    398 
    +      p:ps -> foldr1 orIfNotFound (home_pkg_import p :| map home_pkg_import ps)
    399 
    +      [] -> pure notFound
    400 
    +
    384 401 
         home_pkg_import = findHomeUnitDepModule fc ue home_module_name_providers_map mod_name
    385 402
    386 403 
         unit_state = case homeUnitId <$> mb_home_unit of
    387 404 
             Nothing           -> ue_homeUnitState ue
    388 405 
             Just home_unit_id -> HUG.homeUnitEnv_units $
    389 406 
                                  ue_findHomeUnitEnv home_unit_id ue
    390 
    -    other_fopts = homeUnitDepsFinderOpts ue home_module_name_providers_map
    407 
    +    (provider_fopts, other_fopts) = homeUnitDepsFinderOpts ue home_module_name_providers_map
    391 408 
                                              unit_state mod_name
    392 409
    393 410 
     -- | Search the home-unit graph and otherwise the regular exposed package
    ... ... @@ -401,10 +418,17 @@ findHomeOrRegularPackageModule
    401 418 
       -> ModuleName
    402 419 
       -> IO FindResult
    403 420 
     findHomeOrRegularPackageModule fc fopts ue home_module_name_providers_map mb_home_unit mod_name =
    404 
    -    findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map
    405 
    -                            mb_home_unit mod_name
    406 
    -    `orIfNotFound`
    407 
    -    findExposedPackageModule fc fopts unit_state mod_name NoPkgQual
    421 
    +  case mb_home_unit of
    422 
    +    Just home_unit ->
    423 
    +      findHomeModule fc fopts home_unit mod_name
    424 
    +        `orIfNotFound`
    425 
    +        (findHomeModuleAmongDeps fc ue home_module_name_providers_map
    426 
    +                                 mb_home_unit mod_name
    427 
    +        `combineFindResult`
    428 
    +        findExposedPackageModule fc fopts unit_state mod_name NoPkgQual
    429 
    +        )
    430 
    +    Nothing ->
    431 
    +      findExposedPackageModule fc fopts unit_state mod_name NoPkgQual
    408 432 
       where
    409 433 
         unit_state = case homeUnitId <$> mb_home_unit of
    410 434 
             Nothing           -> ue_homeUnitState ue
    ... ... @@ -470,6 +494,40 @@ orIfNotFound this or_this = do
    470 494 
                  _other -> return res2
    471 495 
         _other -> return res
    472 496
    497 
    +combineFindResult :: Monad m => m FindResult -> m FindResult -> m FindResult
    498 
    +combineFindResult this or_this = do
    499 
    +  res <- this
    500 
    +  case res of
    501 
    +    NotFound { fr_paths = paths1, fr_mods_hidden = mh1
    502 
    +             , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 }
    503 
    +     -> do res2 <- or_this
    504 
    +           case res2 of
    505 
    +             NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2
    506 
    +                      , fr_pkgs_hidden = ph2, fr_unusables = u2
    507 
    +                      , fr_suggestions = s2 }
    508 
    +              -> return (NotFound { fr_paths = paths1 ++ paths2
    509 
    +                                  , fr_pkg = mb_pkg2 -- snd arg is the package search
    510 
    +                                  , fr_mods_hidden = mh1 ++ mh2
    511 
    +                                  , fr_pkgs_hidden = ph1 ++ ph2
    512 
    +                                  , fr_unusables = u1 ++ u2
    513 
    +                                  , fr_suggestions = s1  ++ s2 })
    514 
    +             _other -> return res2
    515 
    +    NoPackage{} -> pure res
    516 
    +    FoundMultiple ms -> do
    517 
    +      otherRes <- or_this
    518 
    +      case otherRes of
    519 
    +        Found _ other_mod -> pure $ FoundMultiple $ ms ++ [(other_mod, HomeOrigin)]
    520 
    +        NoPackage{} -> pure res
    521 
    +        FoundMultiple other_ms -> pure $ FoundMultiple $ ms ++ other_ms
    522 
    +        NotFound{} -> pure res
    523 
    +    Found _mod_location modl -> do
    524 
    +      otherRes <- or_this
    525 
    +      case otherRes of
    526 
    +        Found _ other_mod -> pure $ FoundMultiple $ [(modl, HomeOrigin), (other_mod, HomeOrigin)]
    527 
    +        NoPackage{} -> pure res
    528 
    +        FoundMultiple other_ms -> pure $ FoundMultiple $ [(modl, HomeOrigin)] ++ other_ms
    529 
    +        NotFound{} -> pure res
    530 
    +
    473 531 
     -- | Helper function for 'findHomeModule': this function wraps an IO action
    474 532 
     -- which would look up @mod_name@ in the file system (the home package),
    475 533 
     -- and first consults the 'hsc_FC' cache to see if the lookup has already
    ... ... @@ -483,8 +541,12 @@ homeSearchCache fc home_unit mod_name do_this = do
    483 541
    484 542 
     findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
    485 543 
     findExposedPackageModule fc fopts units mod_name mb_pkg =
    486 
    -  findLookupResult fc fopts
    487 
    -    $ lookupModuleWithSuggestions units mod_name mb_pkg
    544 
    +  findLookupResult fc fopts $
    545 
    +    case lookupModuleWithSuggestions units mod_name mb_pkg of
    546 
    +      lf@(LookupFound _ (u, _))
    547 
    +        | unitId u `Set.member` homeUnitDepends units -> LookupNotFound []
    548 
    +        | otherwise -> lf
    549 
    +      other -> other
    488 550
    489 551 
     findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult
    490 552 
     findExposedPluginPackageModule fc fopts units mod_name =
    ... ... @@ -509,7 +571,7 @@ findLookupResult fc fopts r = case r of
    509 571 
                                              , fr_unusables = []
    510 572 
                                              , fr_suggestions = []})
    511 573 
          LookupMultiple rs ->
    512 
    -       return (FoundMultiple rs)
    574 
    +       return (FoundMultiple $ map (\ (m, o) -> (m, ExternalUnitOrigin o)) rs)
    513 575 
          LookupHidden fr_pkgs_hidden mod_hiddens ->
    514 576 
            return (NotFound{ fr_paths = [], fr_pkg = Nothing
    515 577 
                            , fr_pkgs_hidden
    ... ... @@ -588,6 +650,15 @@ mkHomeHidden uid =
    588 650 
                , fr_unusables = []
    589 651 
                , fr_suggestions = []}
    590 652
    653 
    +notFound =
    654 
    +  NotFound { fr_paths = []
    655 
    +           , fr_pkg = Nothing
    656 
    +           , fr_mods_hidden = []
    657 
    +           , fr_pkgs_hidden = []
    658 
    +           , fr_unusables = []
    659 
    +           , fr_suggestions = []}
    660 
    +
    661 
    +
    591 662 
     findHomePackageModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO FindResult
    592 663 
     findHomePackageModule fc fopts  home_unit mod_name = do
    593 664 
       let uid       = RealUnit (Definite home_unit)

  • compiler/GHC/Unit/Finder/Types.hs
    ... ... @@ -19,6 +19,7 @@ import GHC.Unit.Env
    19 19
    20 20 
     import GHC.Data.FastString
    21 21 
     import GHC.Types.Unique.Set
    22 
    +import GHC.Iface.Errors.Types (HomeOrExternalOrigin)
    22 23
    23 24 
     -- | The 'FinderCache' maps modules to the result of
    24 25 
     -- searching for that module. It records the results of searching for
    ... ... @@ -56,7 +57,7 @@ data FindResult
    56 57 
             -- ^ The module was found
    57 58 
       | NoPackage Unit
    58 59 
             -- ^ The requested unit was not found
    59 
    -  | FoundMultiple [(Module, ModuleOrigin)]
    60 
    +  | FoundMultiple [(Module, HomeOrExternalOrigin)]
    60 61 
             -- ^ _Error_: both in multiple packages
    61 62
    62 63 
             -- | Not found

  • testsuite/tests/ghci/T26300/Makefile
    1 
    +TOP=../../..
    2 
    +include $(TOP)/mk/boilerplate.mk
    3 
    +include $(TOP)/mk/test.mk
    4 
    +
    5 
    +.PHONY: prog-mhu006a
    6 
    +prog-mhu006a:
    7 
    +	'$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) $(WAY_FLAGS) $(ghciWayFlags) \
    8 
    +		-no-user-package-db \
    9 
    +		-unit @unitA -unit @unitB < prog-mhu006a.script

  • testsuite/tests/ghci/T26300/T26300.script
    1 
    +"Report two ambiguous imports."
    2 
    +"The Data.List import is ambiguous with the `base` module."
    3 
    +"Bar module is defined in two home units, as such needs to be reported as ambiguous."

  • testsuite/tests/ghci/T26300/T26300.stderr
    1 
    +a/Main.hs:3:1: error: [GHC-45102]
    2 
    +    Ambiguous module name ‘Data.List’.
    3 
    +    it was found in multiple packages: base-4.23.0.0 b-0.0.1
    4 
    +
    5 
    +a/Main.hs:4:1: error: [GHC-45102]
    6 
    +    Ambiguous module name ‘Bar’.
    7 
    +    it was found in multiple packages: c-0.0.1 b-0.0.1
    8 
    +

  • testsuite/tests/ghci/T26300/T26300.stdout
    1 
    +"Report two ambiguous imports."
    2 
    +"The Data.List import is ambiguous with the `base` module."
    3 
    +"Bar module is defined in two home units, as such needs to be reported as ambiguous."

  • testsuite/tests/ghci/T26300/a/Main.hs
    1 
    +module Main where
    2 
    +
    3 
    +import Data.List
    4 
    +import Bar

  • testsuite/tests/ghci/T26300/all.T
    1 
    +test('T26300',
    2 
    +     [extra_files(['a/', 'b/', 'c/', 'unitA', 'unitB', 'unitC']),
    3 
    +      cmd_prefix('ghciWayFlags=' + config.ghci_way_flags),
    4 
    +      normalise_slashes,
    5 
    +      req_interp],
    6 
    +     ghci_multiunit_script, [['unitA', 'unitB', 'unitC'], 'T26300.script'])

  • testsuite/tests/ghci/T26300/b/Bar.hs
    1 
    +module Bar where

  • testsuite/tests/ghci/T26300/b/Data/List.hs
    1 
    +module Data.List where

  • testsuite/tests/ghci/T26300/c/Bar.hs
    1 
    +module Bar where

  • testsuite/tests/ghci/T26300/unitA
    1 
    +-i
    2 
    +-ia
    3 
    +-this-unit-id a-0.0.1
    4 
    +-package-id b-0.0.1
    5 
    +-package-id c-0.0.1
    6 
    +Main

  • testsuite/tests/ghci/T26300/unitB
    1 
    +-i
    2 
    +-ib
    3 
    +-this-unit-id b-0.0.1
    4 
    +Data.List
    5 
    +Bar

  • testsuite/tests/ghci/T26300/unitC
    1 
    +-i
    2 
    +-ic
    3 
    +-this-unit-id c-0.0.1
    4 
    +Bar

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/commit/21fc5fe9cf1727e2dc7594ee14495cd3619c1245 at 1785751801