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 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

   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

                    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

 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

         glob filename >>= print

 #endif

     ["init", filename] ->

     ["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

       (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 top_dir db@PackageDB { packages = pkgs } =

     db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }

   where

 -- Also perform a similar substitution for the older GHC-specific

 -- "$topdir" variable. The "topdir" is the location of the ghc

 -- installation (obtained from the -B option).

                   -> InstalledPackageInfo -> InstalledPackageInfo

 mungePackagePaths top_dir pkgroot pkg =

    -- TODO: similar code is duplicated in GHC.Unit.Database

     munge_urls  = map munge_url

     (munge_path,munge_url) = mkMungePathUrl top_dir pkgroot

 mkMungePathUrl top_dir pkgroot = (munge_path, munge_url)

    where

     munge_path p

       | otherwise                                = p

     munge_url 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

       packageDbLock = GhcPkg.DbOpenReadWrite lock,

       packages = []

     }

     -- going to be initially empty, so no dependencies are going to be actually

     -- looked up.

     []

       f   -> do

         when (verbosity >= Normal) $

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

   expanded <- if expand_env_vars then expandEnvVars s force

                                  else return s

   updateDBCache verbosity db db_stack

  where

   do_cmd (RemovePackage p) = do

     removeFileSafe file

   do_cmd (AddPackage p) = do

   do_cmd (ModifyPackage p) =

     do_cmd (AddPackage p)

             warn $ "    " ++ pkg

   when (verbosity > Normal) $

   let d = fmap (fromPackageCacheFormat . fst) pkgsGhcCacheFormat

   GhcPkg.writePackageDb filename d pkgsCabalFormat

     `catchIO` \e ->

       if isPermissionError e

       else ioError e

   case packageDbLock db of

       broken = map installedUnitId (brokenPackages pkg_map)

       show_normal PackageDB{ location = db_name, packages = pkg_confs } =

              if null pkg_confs

                  then hPutStrLn stdout "    (no packages)"

                  else hPutStrLn stdout $ unlines (map ("    " ++) (map pp_pkg pkg_confs))

 #else

     let

       show_colour PackageDB{ location = db_name, packages = pkg_confs } =

              if null pkg_confs

                  then hPutStrLn stdout "    (no packages)"

                  else hPutStrLn stdout $ unlines (map ("    " ++) (map pp_pkg pkg_confs))

   doDump expand_pkgroot [ (pkg, locationAbsolute db)

                         | db <- flag_db_stack, pkg <- packages db ]

 doDump expand_pkgroot pkgs = do

   -- fix the encoding to UTF-8, since this is an interchange format

   hSetEncoding stdout utf8

 cannotFindPackage :: PackageArg -> Maybe (PackageDB mode) -> IO a

 cannotFindPackage pkgarg mdb = die $ "cannot find package " ++ pkg_msg pkgarg

   where

     pkg_msg (Id pkgid)           = displayGlobPkgId pkgid

     pkg_msg (IUId ipid)          = display ipid

   checkExposedModules db_stack pkg

   checkOtherModules pkg

   let has_code = Set.null (openModuleSubstFreeHoles (Map.fromList (instantiatedWith pkg)))