if cache_exists

         then do

           debugTraceMsg logger 2 $ text "Using binary package database:" <+> ppr filename

         else do

           -- If there is no package.cache file, we check if the database is not

           -- empty by inspecting if the directory contains any .conf file. If it

    -- * Misc

    , mkMungePathUrl

    , mungeUnitInfoPaths

    )

 where

 import Data.List (intersperse)

 import Control.Exception as Exception

 import Control.Monad (when)

 #if !defined(mingw32_HOST_OS)

 import Data.Bits ((.|.))

 import System.Posix.Types (FileMode)

 #endif

 import System.IO

 import System.IO.Error

 import GHC.IO.Exception (IOErrorType(InappropriateType))

 import qualified GHC.Data.ShortText as ST

 import GHC.IO.Handle.Lock

 -- | @ghc-boot@'s UnitInfo, serialized to the database.

 type DbUnitInfo      = GenericUnitInfo BS.ByteString BS.ByteString BS.ByteString BS.ByteString DbModule

 newtype PackageDbLock = PackageDbLock Handle

 -- | Acquire an exclusive lock related to package DB under given location.

 -- | Release the lock related to package DB.

 unlockPackageDb :: PackageDbLock -> IO ()

 -- | Acquire a lock of given type related to package DB under given location.

 lockPackageDbWith mode file = do

   -- We are trying to open the lock file and then lock it. Thus the lock file

   -- needs to either exist or we need to be able to create it. Ideally we

     (lockFileOpenIn ReadWriteMode)

     (const $ lockFileOpenIn ReadMode)

   where

     lockFileOpenIn io_mode = bracketOnError

       hClose

       -- If file locking support is not available, ignore the error and proceed

       -- normally. Without it the only thing we lose on non-Windows platforms is

 -- | Read the part of the package DB that GHC is interested in.

 --

 readPackageDbForGhc file =

   decodeFromFile file DbOpenReadOnly getDbForGhc >>= \case

     (pkgs, DbOpenReadOnly) -> return pkgs

 -- we additionally receive a PackageDbLock that represents a lock on the

 -- database, so that we can safely update it later.

 --

                           IO (pkgs, DbOpenMode mode PackageDbLock)

 readPackageDbForGhcPkg file mode =

     decodeFromFile file mode getDbForGhcPkg

 -- | Write the whole of the package DB, both parts.

 --

 writePackageDb file ghcPkgs ghcPkgPart = do

   writeFileAtomic file (runPut putDbForGhcPkg)

 #if !defined(mingw32_HOST_OS)

         ghcPart    = encode ghcPkgs

 #if !defined(mingw32_HOST_OS)

 addFileMode file m = do

 #endif

 getHeader :: Get (Word32, Word32)

 -- | Feed a 'Get' decoder with data chunks from a file.

 --

                   IO (pkgs, DbOpenMode mode PackageDbLock)

 decodeFromFile file mode decoder = case mode of

   DbOpenReadOnly -> do

     bracketOnError (lockPackageDb file) unlockPackageDb $ \lock -> do

       (, DbOpenReadWrite lock) <$> decodeFileContents

   where

       feed hnd (runGetIncremental decoder)

     feed hnd (Partial k)  = do chunk <- BS.hGet hnd BS.Lazy.defaultChunkSize

     feed _ (Done _ _ res) = return res

     feed _ (Fail _ _ msg) = ioError err

       where

               `ioeSetErrorString` msg

         loc = "GHC.Unit.Database.readPackageDb"

 -- Copied from Cabal's Distribution.Simple.Utils.

 writeFileAtomic targetPath content = do

   let (targetDir, targetFile) = splitFileName targetPath

   Exception.bracketOnError

     (\(tmpPath, handle) -> do

         BS.Lazy.hPut handle content

         hClose handle

 instance Binary DbUnitInfo where

   put (GenericUnitInfo

     -- rather than letting FilePath change it to use \ as the separator

     stripVarPrefix var path = case ST.stripPrefix var path of

                               Just "" -> Just ""

                               _ -> Nothing

       munge_paths = map munge_path

       munge_urls  = map munge_url

       (munge_path,munge_url) = mkMungePathUrl top_dir pkgroot

                    containers >= 0.5 && < 0.9,

                    directory  >= 1.2 && < 1.4,

                    filepath   >= 1.3 && < 1.6,

                    deepseq    >= 1.4 && < 1.6,

                    ghc-platform  >= 0.1,

                    ghc-toolchain >= 0.1

 	@: # testpkg-1.2.3.4 and newtestpkg-2.0 are both exposed now

 	'$(TEST_HC)' $(TEST_HC_OPTS) -package-db $(PKGCONF04) -c ghcpkg04.hs || true

 # Test stacking of package.confs (also #2441)

 PKGCONF05a=local05a.package.conf

 PKGCONF05b=local05b.package.conf

     return re.sub(r'Warning:.*\n', '', str)

 test('ghcpkg01', [extra_files(['test.pkg', 'test2.pkg', 'test3.pkg'])], makefile_test, [])

 # Use ignore_stderr to prevent (when HADDOCK_DOCS=NO):

 #  warning: haddock-interfaces .. doesn't exist or isn't a file

 import Distribution.Types.LibraryName

 import Distribution.Types.MungedPackageName

 import Distribution.Types.MungedPackageId

 import qualified Data.Version as Version

 import qualified System.FilePath.Posix as FilePath.Posix

 import Text.Printf

 import Prelude hiding (Foldable(..))

 import Data.Char ( toLower )

 import Control.Monad

 import System.Exit ( exitWith, ExitCode(..) )

 import System.Environment ( getArgs, getProgName, getEnv )

 import System.IO

 import System.IO.Error

 import GHC.IO.Exception (IOErrorType(InappropriateType))

 import Data.List ( group, sort, sortBy, nub, partition, find

                  , intercalate, intersperse, unfoldr

                  , isInfixOf, isSuffixOf, isPrefixOf, stripPrefix )

         print filename

         glob filename >>= print

 #endif

     ["register", filename] ->

         registerPackage filename verbosity cli

                         multi_instance

 data PackageDB (mode :: GhcPkg.DbMode)

   = PackageDB {

       -- We need both possibly-relative and definitely-absolute package

       -- db locations. This is because the relative location is used as

       -- an identifier for the db, so it is important we do not modify it.

 -- specified package DB can depend on, since dependencies can only extend

 -- down the stack, not up (e.g. global packages cannot depend on user

 -- packages).

 stackUpTo to_modify = dropWhile ((/= to_modify) . location)

                       -> IO (Either String b)

 readFromSettingsFile settingsFile f = do

   pure $ do

     mySettings <- case maybeReadFuzzy settingsStr of

       Just s -> pure $ Map.fromList s

       Nothing -> Left $ "Can't parse settings file " ++ show settingsFile

     f settingsFile mySettings

                    -> (Target -> b)

                    -> IO (Either String b)

 readFromTargetFile targetFile f = do

   pure $ do

     target <- case maybeReadFuzzy targetStr of

       Just t -> Right t

      case [ f | FlagGlobalConfig f <- my_flags ] of

         -- See Note [Base Dir] for more information on the base dir / top dir.

         [] -> do mb_dir <- getBaseDir

                    Nothing  -> die err_msg

                    Just dir -> do

                      -- Look for where it is given in the settings file, if marked there.

                      -- See Note [Settings file] about this file, and why we need GHC to share it with us.

                      exists_settings_file <- doesFileExist settingsFile

                      erel_db <-

                       if exists_settings_file

                      case erel_db of

                       -- If the version of GHC doesn't have this field or the settings file

                       -- doesn't exist for some reason, look in the libdir.

                       Left err -> do

                         r <- lookForPackageDBIn dir

                         case r of

                           Just path -> return (dir, path)

         fs -> do

           -- The value of the $topdir variable used in some package descriptions

           -- Note that the way we calculate this is slightly different to how it

           -- is done in ghc itself. We rely on the convention that the global

           -- package db lives in ghc's libdir.

           top_dir <- absolutePath (takeDirectory pkg_db)

           return (top_dir, pkg_db)

   -- getXdgDirectory can fail (e.g. if $HOME isn't set)

   mb_user_conf <-

       _ | no_user_db -> return Nothing

       [] -> do

         exists_settings_file <- doesFileExist targetFile

         targetArchOS <- case exists_settings_file of

           False -> do

         -- otherwise we use $XDG_DATA_HOME/$UNIQUE_SUBDIR

         --

         -- UNIQUE_SUBDIR is typically a combination of the target platform and GHC version

           ]

         case m_appdir of

           Nothing -> return Nothing

           Just dir -> do

             lookForPackageDBIn dir >>= \case

               Just f  -> return (Just (f, True))

       fs -> return (Just (last fs, True))

   e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH")

   let env_stack =

                 Left  _ -> sys_databases

                 Right path

                   | otherwise

                   -> splitSearchPath path

                       | Just (user_conf, _user_exists) <- mb_user_conf

                       = Just user_conf

                is_db_flag FlagGlobal     = Just virt_global_conf

                is_db_flag _              = Nothing

   let flag_db_names | null db_flags = env_stack

   -- stack, unless any of them are present in the stack

   -- already.

   let final_stack = filter (`notElem` env_stack)

                      ++ env_stack

       top_db = if null db_flags

   when (verbosity > Normal) $ do

     infoLn ("db stack: " ++ show (map location db_stack))

     F.forM_ db_to_operate_on $ \db ->

     infoLn ("flag db stack: " ++ show (map location flag_db_stack))

   return (db_stack, db_to_operate_on, flag_db_stack)

         return (db_stack, GhcPkg.DbOpenReadWrite to_modify)

       where

         couldntOpenDbForModification db_path e = die $ "Couldn't open database "

         -- Parse package db in read-only mode.

         readDatabase db_path = do

           db <- readParseDatabase verbosity mb_user_conf

                                   GhcPkg.DbOpenReadOnly use_cache db_path

           if expand_vars

             else return db

     stateSequence :: Monad m => s -> [s -> m (a, s)] -> m ([a], s)

       (as, s'') <- stateSequence s' ms

       return (a : as, s'')

 lookForPackageDBIn dir = do

   exists_dir <- doesDirectoryExist path_dir

   if exists_dir then return (Just path_dir) else do

     exists_file <- doesFileExist path_file

     if exists_file then return (Just path_file) else return Nothing

 readParseDatabase :: forall mode t. Verbosity

                   -> GhcPkg.DbOpenMode mode t

                   -> Bool -- use cache

                   -> IO (PackageDB mode)

 readParseDatabase verbosity mb_user_conf mode use_cache path

   -- the user database (only) is allowed to be non-existent

                 Just db -> return db

                 Nothing ->

                   die $ "ghc no longer supports single-file style package "

                      ++ "to create the database with the correct format."

            | otherwise -> ioError err

                         -- It's fine if the cache is not there as long as the

                         -- database is empty.

                         when (not $ null confs) $ do

                             warn ("ghc will fail to read this package db. " ++

                                   recacheAdvice)

                       else do

                   ignore_cache (const $ return ())

                 Right tcache -> do

                   when (verbosity >= Verbose) $ do

                   -- If any of the .conf files is newer than package.cache, we

                   -- assume that cache is out of date.

                   cache_outdated <- (`anyM` confs) $ \conf ->

                   if not cache_outdated

                       then do

                           when (verbosity > Normal) $

                           GhcPkg.readPackageDbForGhcPkg cache mode

                             >>= uncurry mkPackageDB

                       else do

                           whenReportCacheErrors $ do

                               warn ("ghc will see an old view of this " ++

                                     "package db. " ++ recacheAdvice)

                           ignore_cache $ \file -> do

                                     GT -> " (older than cache)"

                                     EQ -> " (same as cache)"

                               warn ("Timestamp " ++ show tFile

             where

                  ignore_cache checkTime = do

                      -- If we're opening for modification, we need to acquire a

                      -- lock even if we don't open the cache now, because we are

           packages = pkgs

         }

 parseSingletonPackageConf verbosity file = do

 mungePackageDBPaths :: FilePath -> PackageDB mode -> PackageDB mode

 mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =

   where

     pkgroot = takeDirectory $ dropTrailingPathSeparator (locationAbsolute db)

     -- It so happens that for both styles of package db ("package.conf"

       | Just p' <- stripVarPrefix "$httptopdir"   p = toUrlPath top_dir p'

       | otherwise                                   = p

     toUrlPath r p = "file:///"

                  -- URLs always use posix style '/' separators:

                  ++ FilePath.Posix.joinPath

                         (r : -- We need to drop a leading "/" or "\\"

                              -- if there is one:

                                        (FilePath.splitDirectories p))

     -- We could drop the separator here, and then use </> above. However,

     -- rather than letting FilePath change it to use \ as the separator

     stripVarPrefix var path = case stripPrefix var path of

                               Just [] -> Just []

                               _ -> Nothing

 -- -----------------------------------------------------------------------------

 -- ghc itself also cooperates in this workaround

                                  -> IO (Maybe (PackageDB mode))

 tryReadParseOldFileStyleDatabase verbosity mb_user_conf

                                  mode use_cache path = do

   -- assumes we've already established that path exists and is not a dir

   if take 2 content == "[]"

     then do

       path_abs <- absolutePath path

       let path_dir = adjustOldDatabasePath path

       direxists <- doesDirectoryExist path_dir

       if direxists

         then do

 adjustOldFileStylePackageDB :: PackageDB mode -> IO (PackageDB mode)

 adjustOldFileStylePackageDB db = do

   -- assumes we have not yet established if it's an old style or not

   case fmap (take 2) mcontent of

     -- it is an old style and empty db, so look for a dir kind in location.d/

     Just "[]" -> return db {

       }

     -- it is old style but not empty, we have to bail

     Just  _   -> die $ "ghc no longer supports single-file style package "

                     ++ "to create the database with the correct format."

     -- probably not old style, carry on as normal

     Nothing   -> return db

 -- -----------------------------------------------------------------------------

 -- Creating a new package DB

 initPackageDB filename verbosity _flags = do

   b1 <- doesFileExist filename

   when b1 eexist

   b2 <- doesDirectoryExist filename

       f   -> do

         when (verbosity >= Normal) $

             info ("Reading package info from " ++ show f ++ " ... ")

   expanded <- if expand_env_vars then expandEnvVars s force

                                  else return s

   -- validate the expanded pkg, but register the unexpanded

   pkgroot <- absolutePath (takeDirectory to_modify)

   let top_dir = takeDirectory (location (last db_stack))

   let truncated_stack = stackUpTo to_modify db_stack

   -- truncate the stack for validation, because we don't allow

   updateDBCache verbosity db db_stack

  where

   do_cmd (RemovePackage p) = do

     removeFileSafe file

   do_cmd (AddPackage p) = do