{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedRecordDot   #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TupleSections         #-}

-- This module is based on GHC's utils\ghc-pkg\Main.hs at

-- commit f66fc15f2e6849125074bcfeb44334a663323ca6 (see GHC merge request

-- !11142), with:

-- * changeDBDir' does not perform an effective @ghc-pkg recache@,

-- * the cache is not used,

-- * consistency checks are not performed,

-- * use Stack program name,

-- * use "Stack.Prelude" rather than "Prelude",

-- * use 'RIO' @env@ monad,

-- * use well-typed representations of paths from the @path@ package,

-- * add pretty messages and exceptions,

-- * redundant code deleted,

-- * Hlint applied, and

-- * explicit import lists.

--

-- The version of the ghc-pkg executable supplied with GHCs published before

-- 28 August 2023 does not efficiently bulk unregister. This module exports a

-- function that does efficiently bulk unregister.


module GHC.Utils.GhcPkg.Main.Compat
  ( ghcPkgUnregisterForce
  ) where

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

--

-- (c) The University of Glasgow 2004-2009.

--

-- Package management tool

--

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


import qualified Data.Foldable as F
import qualified Data.Traversable as F
import           Distribution.InstalledPackageInfo as Cabal
import           Distribution.Package ( UnitId, mungedId )
import qualified Distribution.Parsec as Cabal
import           Distribution.Text ( display )
import           Distribution.Version ( nullVersion )
import           GHC.IO.Exception (IOErrorType(InappropriateType))
import qualified GHC.Unit.Database as GhcPkg
import           Path
                   ( SomeBase (..), fileExtension, mapSomeBase, parseRelFile
                   , parseSomeDir, prjSomeBase
                   )
import qualified Path as P
import           Path.IO
                   ( createDirIfMissing, doesDirExist, listDir, removeFile )
import qualified RIO.ByteString as BS
import           RIO.List ( isPrefixOf, stripSuffix )
import           RIO.NonEmpty ( nonEmpty )
import qualified RIO.NonEmpty as NE
import           Stack.Constants ( relFilePackageCache )
import           Stack.Prelude hiding ( display )
import           System.Environment ( getEnv )
import           System.FilePath as FilePath
import           System.IO ( readFile )
import           System.IO.Error
                   ( ioeGetErrorType, ioError, isDoesNotExistError )

-- | Function equivalent to:

--

-- > ghc-pkg --no-user-package-db --package-db=<pkgDb> unregister [--ipid] <P>

--

ghcPkgUnregisterForce ::
     HasTerm env
  => Path Abs Dir -- ^ Path to the global package database

  -> Path Abs Dir -- ^ Path to the package database

  -> Bool -- ^ Apply ghc-pkg's --ipid, --unit-id flag?

  -> [String] -- ^ Packages to unregister

  -> RIO env ()
ghcPkgUnregisterForce :: forall env.
HasTerm env =>
Path Abs Dir -> Path Abs Dir -> Bool -> [[Char]] -> RIO env ()
ghcPkgUnregisterForce Path Abs Dir
globalDb Path Abs Dir
pkgDb Bool
hasIpid [[Char]]
pkgarg_strs = do
  [PackageArg]
pkgargs <- [[Char]] -> ([Char] -> RIO env PackageArg) -> RIO env [PackageArg]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[Char]]
pkgarg_strs (([Char] -> RIO env PackageArg) -> RIO env [PackageArg])
-> ([Char] -> RIO env PackageArg) -> RIO env [PackageArg]
forall a b. (a -> b) -> a -> b
$ AsPackageArg -> [Char] -> RIO env PackageArg
forall env. AsPackageArg -> [Char] -> RIO env PackageArg
readPackageArg AsPackageArg
as_arg
  [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyDebugL
    ([StyleDoc] -> RIO env ()) -> [StyleDoc] -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Char] -> StyleDoc
flow [Char]
"Unregistering from"
    StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: (Path Abs Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs Dir
pkgDb StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":")
    StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: Maybe Style -> Bool -> [StyleDoc] -> [StyleDoc]
forall a. Pretty a => Maybe Style -> Bool -> [a] -> [StyleDoc]
mkNarrativeList (Style -> Maybe Style
forall a. a -> Maybe a
Just Style
Current) Bool
False
        ((PackageArg -> StyleDoc) -> [PackageArg] -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc)
-> (PackageArg -> [Char]) -> PackageArg -> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageArg -> [Char]
forall a. Show a => a -> [Char]
show) [PackageArg]
pkgargs :: [StyleDoc])
  Path Abs Dir -> [PackageArg] -> Path Abs Dir -> RIO env ()
forall env.
HasTerm env =>
Path Abs Dir -> [PackageArg] -> Path Abs Dir -> RIO env ()
unregisterPackages Path Abs Dir
globalDb [PackageArg]
pkgargs Path Abs Dir
pkgDb
 where
  as_arg :: AsPackageArg
as_arg = if Bool
hasIpid then AsPackageArg
AsUnitId else AsPackageArg
AsDefault

-- | Type representing \'pretty\' exceptions thrown by functions exported by the

-- "GHC.Utils.GhcPkg.Main.Compat" module.

data GhcPkgPrettyException
  = CannotParse !String !String !String
  | CannotOpenDBForModification !(SomeBase Dir) !IOException
  | SingleFileDBUnsupported !(SomeBase Dir)
  | ParsePackageInfoExceptions !String
  | CannotFindPackage !PackageArg !(Maybe (SomeBase Dir))
  | CannotParseRelFileBug !String
  | CannotParseDirectoryWithDBug !String
  deriving (Int -> GhcPkgPrettyException -> ShowS
[GhcPkgPrettyException] -> ShowS
GhcPkgPrettyException -> [Char]
(Int -> GhcPkgPrettyException -> ShowS)
-> (GhcPkgPrettyException -> [Char])
-> ([GhcPkgPrettyException] -> ShowS)
-> Show GhcPkgPrettyException
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GhcPkgPrettyException -> ShowS
showsPrec :: Int -> GhcPkgPrettyException -> ShowS
$cshow :: GhcPkgPrettyException -> [Char]
show :: GhcPkgPrettyException -> [Char]
$cshowList :: [GhcPkgPrettyException] -> ShowS
showList :: [GhcPkgPrettyException] -> ShowS
Show, Typeable)

instance Pretty GhcPkgPrettyException where
  pretty :: GhcPkgPrettyException -> StyleDoc
pretty (CannotParse [Char]
str [Char]
what [Char]
e) =
    StyleDoc
"[S-6512]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"cannot parse"
         , Style -> StyleDoc -> StyleDoc
style Style
Current ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
str)
         , [Char] -> StyleDoc
flow [Char]
"as a"
         , [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
what StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
":"
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
e
  pretty (CannotOpenDBForModification SomeBase Dir
db_path IOException
e) =
    StyleDoc
"[S-3384]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"Couldn't open database"
         , SomeBase Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty SomeBase Dir
db_path
         , [Char] -> StyleDoc
flow [Char]
"for modification:"
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
string (IOException -> [Char]
forall e. Exception e => e -> [Char]
displayException IOException
e)
  pretty (SingleFileDBUnsupported SomeBase Dir
path) =
    StyleDoc
"[S-1430]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"ghc no longer supports single-file style package databases"
         , StyleDoc -> StyleDoc
parens (SomeBase Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty SomeBase Dir
path)
         , StyleDoc
"use"
         , Style -> StyleDoc -> StyleDoc
style Style
Shell ([Char] -> StyleDoc
flow [Char]
"ghc-pkg init")
         , [Char] -> StyleDoc
flow [Char]
"to create the database with the correct format."
         ]
  pretty (ParsePackageInfoExceptions [Char]
errs) =
    StyleDoc
"[S-5996]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [Char] -> StyleDoc
flow [Char]
errs
  pretty (CannotFindPackage PackageArg
pkgarg Maybe (SomeBase Dir)
mdb_path) =
    StyleDoc
"[S-3189]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
         [ [Char] -> StyleDoc
flow [Char]
"cannot find package"
         , Style -> StyleDoc -> StyleDoc
style Style
Current (PackageArg -> StyleDoc
pkg_msg PackageArg
pkgarg)
         , StyleDoc
-> (SomeBase Dir -> StyleDoc) -> Maybe (SomeBase Dir) -> StyleDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
             StyleDoc
""
             (\SomeBase Dir
db_path -> [StyleDoc] -> StyleDoc
fillSep [StyleDoc
"in", SomeBase Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty SomeBase Dir
db_path])
             Maybe (SomeBase Dir)
mdb_path
         ]
   where
    pkg_msg :: PackageArg -> StyleDoc
pkg_msg (Substring [Char]
pkgpat [Char] -> Bool
_) = [StyleDoc] -> StyleDoc
fillSep [StyleDoc
"matching", [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
pkgpat]
    pkg_msg PackageArg
pkgarg' = [Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString ([Char] -> StyleDoc) -> [Char] -> StyleDoc
forall a b. (a -> b) -> a -> b
$ PackageArg -> [Char]
forall a. Show a => a -> [Char]
show PackageArg
pkgarg'
  pretty (CannotParseRelFileBug [Char]
relFileName) = [Char] -> StyleDoc -> StyleDoc
bugPrettyReport [Char]
"[S-9323]" (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$
    [StyleDoc] -> StyleDoc
fillSep
      [ [Char] -> StyleDoc
flow [Char]
"changeDBDir': Could not parse"
      , Style -> StyleDoc -> StyleDoc
style Style
File ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
relFileName)
      , [Char] -> StyleDoc
flow [Char]
"as a relative path to a file."
      ]
  pretty (CannotParseDirectoryWithDBug [Char]
dirName) = [Char] -> StyleDoc -> StyleDoc
bugPrettyReport [Char]
"[S-7651]" (StyleDoc -> StyleDoc) -> StyleDoc -> StyleDoc
forall a b. (a -> b) -> a -> b
$
    [StyleDoc] -> StyleDoc
fillSep
      [ [Char] -> StyleDoc
flow [Char]
"adjustOldDatabasePath: Could not parse"
      , Style -> StyleDoc -> StyleDoc
style Style
Dir ([Char] -> StyleDoc
forall a. IsString a => [Char] -> a
fromString [Char]
dirName)
      , [Char] -> StyleDoc
flow [Char]
"as a directory."
      ]

instance Exception GhcPkgPrettyException

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

-- Do the business


-- | Enum flag representing argument type

data AsPackageArg
  = AsUnitId
  | AsDefault

-- | Represents how a package may be specified by a user on the command line.

data PackageArg
    -- | A package identifier foo-0.1, or a glob foo-*

  = Id GlobPackageIdentifier
    -- | An installed package ID foo-0.1-HASH.  This is guaranteed to uniquely

    -- match a single entry in the package database.

  | IUId UnitId
    -- | A glob against the package name.  The first string is the literal

    -- glob, the second is a function which returns @True@ if the argument

    -- matches.

  | Substring String (String -> Bool)

instance Show PackageArg where
  show :: PackageArg -> [Char]
show (Id GlobPackageIdentifier
pkgid) = GlobPackageIdentifier -> [Char]
displayGlobPkgId GlobPackageIdentifier
pkgid
  show (IUId UnitId
ipid) = UnitId -> [Char]
forall a. Pretty a => a -> [Char]
display UnitId
ipid
  show (Substring [Char]
pkgpat [Char] -> Bool
_) = [Char]
pkgpat

parseCheck :: Cabal.Parsec a => String -> String -> RIO env a
parseCheck :: forall a env. Parsec a => [Char] -> [Char] -> RIO env a
parseCheck [Char]
str [Char]
what =
  case [Char] -> Either [Char] a
forall a. Parsec a => [Char] -> Either [Char] a
Cabal.eitherParsec [Char]
str of
    Left [Char]
e  -> GhcPkgPrettyException -> RIO env a
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (GhcPkgPrettyException -> RIO env a)
-> GhcPkgPrettyException -> RIO env a
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char] -> GhcPkgPrettyException
CannotParse [Char]
str [Char]
what [Char]
e
    Right a
x -> a -> RIO env a
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

-- | Either an exact 'PackageIdentifier', or a glob for all packages

-- matching 'PackageName'.

data GlobPackageIdentifier
  = ExactPackageIdentifier MungedPackageId
  | GlobPackageIdentifier  MungedPackageName

displayGlobPkgId :: GlobPackageIdentifier -> String
displayGlobPkgId :: GlobPackageIdentifier -> [Char]
displayGlobPkgId (ExactPackageIdentifier MungedPackageId
pid) = MungedPackageId -> [Char]
forall a. Pretty a => a -> [Char]
display MungedPackageId
pid
displayGlobPkgId (GlobPackageIdentifier MungedPackageName
pn) = MungedPackageName -> [Char]
forall a. Pretty a => a -> [Char]
display MungedPackageName
pn [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"-*"

readGlobPkgId :: String -> RIO env GlobPackageIdentifier
readGlobPkgId :: forall env. [Char] -> RIO env GlobPackageIdentifier
readGlobPkgId [Char]
str = case [Char] -> [Char] -> Maybe [Char]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix [Char]
"-*" [Char]
str of
  Maybe [Char]
Nothing ->
    MungedPackageId -> GlobPackageIdentifier
ExactPackageIdentifier (MungedPackageId -> GlobPackageIdentifier)
-> RIO env MungedPackageId -> RIO env GlobPackageIdentifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [Char] -> RIO env MungedPackageId
forall a env. Parsec a => [Char] -> [Char] -> RIO env a
parseCheck [Char]
str [Char]
"package identifier (exact)"
  Just [Char]
str' ->
    MungedPackageName -> GlobPackageIdentifier
GlobPackageIdentifier (MungedPackageName -> GlobPackageIdentifier)
-> RIO env MungedPackageName -> RIO env GlobPackageIdentifier
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [Char] -> RIO env MungedPackageName
forall a env. Parsec a => [Char] -> [Char] -> RIO env a
parseCheck [Char]
str' [Char]
"package identifier (glob)"

readPackageArg :: AsPackageArg -> String -> RIO env PackageArg
readPackageArg :: forall env. AsPackageArg -> [Char] -> RIO env PackageArg
readPackageArg AsPackageArg
AsUnitId [Char]
str = UnitId -> PackageArg
IUId (UnitId -> PackageArg) -> RIO env UnitId -> RIO env PackageArg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> [Char] -> RIO env UnitId
forall a env. Parsec a => [Char] -> [Char] -> RIO env a
parseCheck [Char]
str [Char]
"installed package id"
readPackageArg AsPackageArg
AsDefault [Char]
str = GlobPackageIdentifier -> PackageArg
Id (GlobPackageIdentifier -> PackageArg)
-> RIO env GlobPackageIdentifier -> RIO env PackageArg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> RIO env GlobPackageIdentifier
forall env. [Char] -> RIO env GlobPackageIdentifier
readGlobPkgId [Char]
str

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

-- Package databases


data PackageDB (mode :: GhcPkg.DbMode) = PackageDB
  { forall (mode :: DbMode). PackageDB mode -> SomeBase Dir
location :: !(SomeBase Dir)
    -- We only need possibly-relative package db location. The relative

    -- location is used as an identifier for the db, so it is important we do

    -- not modify it.

  , forall (mode :: DbMode).
PackageDB mode -> DbOpenMode mode PackageDbLock
packageDbLock :: !(GhcPkg.DbOpenMode mode GhcPkg.PackageDbLock)
    -- If package db is open in read write mode, we keep its lock around for

    -- transactional updates.

  , forall (mode :: DbMode). PackageDB mode -> [InstalledPackageInfo]
packages :: [InstalledPackageInfo]
  }

-- | A stack of package databases. Convention: head is the topmost in the stack.

type PackageDBStack = [PackageDB 'GhcPkg.DbReadOnly]

-- | Selector for picking the right package DB to modify as 'modify' changes the

-- first database that contains a specific package.

newtype DbModifySelector = ContainsPkg PackageArg

getPkgDatabases ::
     forall env. HasTerm env
  => Path Abs Dir
     -- ^ Path to the global package database.

  -> PackageArg
  -> Path Abs Dir
     -- ^ Path to the package database.

  -> RIO
       env
       ( PackageDBStack
          -- the real package DB stack: [global,user] ++ DBs specified on the

          -- command line with -f.

       , GhcPkg.DbOpenMode GhcPkg.DbReadWrite (PackageDB GhcPkg.DbReadWrite)
         -- which one to modify, if any

       , PackageDBStack
         -- the package DBs specified on the command line, or [global,user]

         -- otherwise. This is used as the list of package DBs for commands

         -- that just read the DB, such as 'list'.

       )
getPkgDatabases :: forall env.
HasTerm env =>
Path Abs Dir
-> PackageArg
-> Path Abs Dir
-> RIO
     env
     (PackageDBStack, DbOpenMode 'DbReadWrite (PackageDB 'DbReadWrite),
      PackageDBStack)
getPkgDatabases Path Abs Dir
globalDb PackageArg
pkgarg Path Abs Dir
pkgDb = do
  -- Second we determine the location of the global package config.  On Windows,

  -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the

  -- location is passed to the binary using the --global-package-db flag by the

  -- wrapper script.

  let sys_databases :: [SomeBase Dir]
sys_databases = [Path Abs Dir -> SomeBase Dir
forall t. Path Abs t -> SomeBase t
Abs Path Abs Dir
globalDb]
  Either IOException [Char]
e_pkg_path <- RIO env [Char] -> RIO env (Either IOException [Char])
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO (IO [Char] -> RIO env [Char]
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> RIO env [Char]) -> IO [Char] -> RIO env [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
System.Environment.getEnv [Char]
"GHC_PACKAGE_PATH")
  let env_stack :: [SomeBase Dir]
env_stack =
        case [Char] -> Maybe (NonEmpty Char)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Char] -> Maybe (NonEmpty Char))
-> Either IOException [Char]
-> Either IOException (Maybe (NonEmpty Char))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either IOException [Char]
e_pkg_path of
          Left IOException
_ -> [SomeBase Dir]
sys_databases
          Right Maybe (NonEmpty Char)
Nothing -> []
          Right (Just NonEmpty Char
path)
            | Char -> Bool
isSearchPathSeparator (NonEmpty Char -> Char
forall a. NonEmpty a -> a
NE.last NonEmpty Char
path)
            -> ([Char] -> Maybe (SomeBase Dir)) -> [[Char]] -> [SomeBase Dir]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Char] -> Maybe (SomeBase Dir)
forall (m :: * -> *). MonadThrow m => [Char] -> m (SomeBase Dir)
parseSomeDir ([Char] -> [[Char]]
splitSearchPath (NonEmpty Char -> [Char]
forall a. NonEmpty a -> [a]
NE.init NonEmpty Char
path)) [SomeBase Dir] -> [SomeBase Dir] -> [SomeBase Dir]
forall a. Semigroup a => a -> a -> a
<> [SomeBase Dir]
sys_databases
            | Bool
otherwise
            -> ([Char] -> Maybe (SomeBase Dir)) -> [[Char]] -> [SomeBase Dir]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [Char] -> Maybe (SomeBase Dir)
forall (m :: * -> *). MonadThrow m => [Char] -> m (SomeBase Dir)
parseSomeDir ([Char] -> [[Char]]
splitSearchPath ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ NonEmpty Char -> [Char]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Char
path)

  -- -f flags on the command line add to the database stack, unless any of them

  -- are present in the stack already.

  let final_stack :: [SomeBase Dir]
final_stack = [Path Abs Dir -> SomeBase Dir
forall t. Path Abs t -> SomeBase t
Abs Path Abs Dir
pkgDb | Path Abs Dir -> SomeBase Dir
forall t. Path Abs t -> SomeBase t
Abs Path Abs Dir
pkgDb SomeBase Dir -> [SomeBase Dir] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [SomeBase Dir]
env_stack] [SomeBase Dir] -> [SomeBase Dir] -> [SomeBase Dir]
forall a. Semigroup a => a -> a -> a
<> [SomeBase Dir]
env_stack

  (PackageDBStack
db_stack, DbOpenMode 'DbReadWrite (PackageDB 'DbReadWrite)
db_to_operate_on) <- Path Abs Dir
-> [SomeBase Dir]
-> RIO
     env
     (PackageDBStack, DbOpenMode 'DbReadWrite (PackageDB 'DbReadWrite))
getDatabases Path Abs Dir
pkgDb [SomeBase Dir]
final_stack

  let flag_db_stack :: PackageDBStack
flag_db_stack = [ PackageDB 'DbReadOnly
db | PackageDB 'DbReadOnly
db <- PackageDBStack
db_stack, PackageDB 'DbReadOnly
db.location SomeBase Dir -> SomeBase Dir -> Bool
forall a. Eq a => a -> a -> Bool
== Path Abs Dir -> SomeBase Dir
forall t. Path Abs t -> SomeBase t
Abs Path Abs Dir
pkgDb ]

  [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyDebugL
    ([StyleDoc] -> RIO env ()) -> [StyleDoc] -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Char] -> StyleDoc
flow [Char]
"Db stack:"
    StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: (PackageDB 'DbReadOnly -> StyleDoc) -> PackageDBStack -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SomeBase Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty (SomeBase Dir -> StyleDoc)
-> (PackageDB 'DbReadOnly -> SomeBase Dir)
-> PackageDB 'DbReadOnly
-> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.location)) PackageDBStack
db_stack
  DbOpenMode 'DbReadWrite (PackageDB 'DbReadWrite)
-> (PackageDB 'DbReadWrite -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ DbOpenMode 'DbReadWrite (PackageDB 'DbReadWrite)
db_to_operate_on ((PackageDB 'DbReadWrite -> RIO env ()) -> RIO env ())
-> (PackageDB 'DbReadWrite -> RIO env ()) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ \PackageDB 'DbReadWrite
db ->
    [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyDebugL
      [ StyleDoc
"Modifying:"
      , SomeBase Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty PackageDB 'DbReadWrite
db.location
      ]
  [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyDebugL
    ([StyleDoc] -> RIO env ()) -> [StyleDoc] -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Char] -> StyleDoc
flow [Char]
"Flag db stack:"
    StyleDoc -> [StyleDoc] -> [StyleDoc]
forall a. a -> [a] -> [a]
: (PackageDB 'DbReadOnly -> StyleDoc) -> PackageDBStack -> [StyleDoc]
forall a b. (a -> b) -> [a] -> [b]
map (SomeBase Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty (SomeBase Dir -> StyleDoc)
-> (PackageDB 'DbReadOnly -> SomeBase Dir)
-> PackageDB 'DbReadOnly
-> StyleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.location)) PackageDBStack
flag_db_stack

  (PackageDBStack, DbOpenMode 'DbReadWrite (PackageDB 'DbReadWrite),
 PackageDBStack)
-> RIO
     env
     (PackageDBStack, DbOpenMode 'DbReadWrite (PackageDB 'DbReadWrite),
      PackageDBStack)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageDBStack
db_stack, DbOpenMode 'DbReadWrite (PackageDB 'DbReadWrite)
db_to_operate_on, PackageDBStack
flag_db_stack)
 where
  getDatabases :: Path Abs Dir
-> [SomeBase Dir]
-> RIO
     env
     (PackageDBStack, DbOpenMode 'DbReadWrite (PackageDB 'DbReadWrite))
getDatabases Path Abs Dir
flag_db_name [SomeBase Dir]
final_stack = do
    -- The package db we open in read write mode is the first one included in

    -- flag_db_names that contains specified package. Therefore we need to

    -- open each one in read/write mode first and decide whether it's for

    -- modification based on its contents.

      (PackageDBStack
db_stack, Maybe (PackageDB 'DbReadWrite)
mto_modify) <- Maybe (PackageDB 'DbReadWrite)
-> [Maybe (PackageDB 'DbReadWrite)
    -> RIO env (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite))]
-> RIO env (PackageDBStack, Maybe (PackageDB 'DbReadWrite))
forall (m :: * -> *) s a.
Monad m =>
s -> [s -> m (a, s)] -> m ([a], s)
stateSequence Maybe (PackageDB 'DbReadWrite)
forall a. Maybe a
Nothing
        [ \case
            to_modify :: Maybe (PackageDB 'DbReadWrite)
to_modify@(Just PackageDB 'DbReadWrite
_) -> (, Maybe (PackageDB 'DbReadWrite)
to_modify) (PackageDB 'DbReadOnly
 -> (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite)))
-> RIO env (PackageDB 'DbReadOnly)
-> RIO env (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeBase Dir -> RIO env (PackageDB 'DbReadOnly)
readDatabase SomeBase Dir
db_path
            Maybe (PackageDB 'DbReadWrite)
Nothing -> if SomeBase Dir
db_path SomeBase Dir -> SomeBase Dir -> Bool
forall a. Eq a => a -> a -> Bool
/= Path Abs Dir -> SomeBase Dir
forall t. Path Abs t -> SomeBase t
Abs Path Abs Dir
flag_db_name
              then (, Maybe (PackageDB 'DbReadWrite)
forall a. Maybe a
Nothing) (PackageDB 'DbReadOnly
 -> (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite)))
-> RIO env (PackageDB 'DbReadOnly)
-> RIO env (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SomeBase Dir -> RIO env (PackageDB 'DbReadOnly)
readDatabase SomeBase Dir
db_path
              else do
                let hasPkg :: PackageDB mode -> Bool
                    hasPkg :: forall (mode :: DbMode). PackageDB mode -> Bool
hasPkg = Bool -> Bool
not (Bool -> Bool)
-> (PackageDB mode -> Bool) -> PackageDB mode -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [InstalledPackageInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([InstalledPackageInfo] -> Bool)
-> (PackageDB mode -> [InstalledPackageInfo])
-> PackageDB mode
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageArg -> [InstalledPackageInfo] -> [InstalledPackageInfo]
findPackage PackageArg
pkgarg ([InstalledPackageInfo] -> [InstalledPackageInfo])
-> (PackageDB mode -> [InstalledPackageInfo])
-> PackageDB mode
-> [InstalledPackageInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.packages)

                    openRo :: IOException
-> RIO env (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite))
openRo (IOException
e::IOException) = do
                      PackageDB 'DbReadOnly
db <- SomeBase Dir -> RIO env (PackageDB 'DbReadOnly)
readDatabase SomeBase Dir
db_path
                      if PackageDB 'DbReadOnly -> Bool
forall (mode :: DbMode). PackageDB mode -> Bool
hasPkg PackageDB 'DbReadOnly
db
                        then
                          GhcPkgPrettyException
-> RIO env (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite))
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (GhcPkgPrettyException
 -> RIO env (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite)))
-> GhcPkgPrettyException
-> RIO env (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite))
forall a b. (a -> b) -> a -> b
$ SomeBase Dir -> IOException -> GhcPkgPrettyException
CannotOpenDBForModification SomeBase Dir
db_path IOException
e
                        else (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite))
-> RIO env (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageDB 'DbReadOnly
db, Maybe (PackageDB 'DbReadWrite)
forall a. Maybe a
Nothing)

                -- If we fail to open the database in read/write mode, we need

                -- to check if it's for modification first before throwing an

                -- error, so we attempt to open it in read only mode.

                (IOException
 -> RIO env (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite)))
-> RIO env (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite))
-> RIO env (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite))
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
handle IOException
-> RIO env (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite))
openRo (RIO env (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite))
 -> RIO env (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite)))
-> RIO env (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite))
-> RIO env (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite))
forall a b. (a -> b) -> a -> b
$ do
                  PackageDB 'DbReadWrite
db <- DbOpenMode 'DbReadWrite DbModifySelector
-> SomeBase Dir -> RIO env (PackageDB 'DbReadWrite)
forall (mode :: DbMode) t env.
HasTerm env =>
DbOpenMode mode t -> SomeBase Dir -> RIO env (PackageDB mode)
readParseDatabase
                          (DbModifySelector -> DbOpenMode 'DbReadWrite DbModifySelector
forall t. t -> DbOpenMode 'DbReadWrite t
GhcPkg.DbOpenReadWrite (DbModifySelector -> DbOpenMode 'DbReadWrite DbModifySelector)
-> DbModifySelector -> DbOpenMode 'DbReadWrite DbModifySelector
forall a b. (a -> b) -> a -> b
$ PackageArg -> DbModifySelector
ContainsPkg PackageArg
pkgarg) SomeBase Dir
db_path
                  let ro_db :: PackageDB 'DbReadOnly
ro_db = PackageDB 'DbReadWrite
db { packageDbLock = GhcPkg.DbOpenReadOnly }
                  if PackageDB 'DbReadWrite -> Bool
forall (mode :: DbMode). PackageDB mode -> Bool
hasPkg PackageDB 'DbReadWrite
db
                    then (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite))
-> RIO env (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageDB 'DbReadOnly
ro_db, PackageDB 'DbReadWrite -> Maybe (PackageDB 'DbReadWrite)
forall a. a -> Maybe a
Just PackageDB 'DbReadWrite
db)
                    else do
                      -- If the database is not for modification after all,

                      -- drop the write lock as we are already finished with

                      -- the database.

                      case PackageDB 'DbReadWrite
db.packageDbLock of
                        GhcPkg.DbOpenReadWrite PackageDbLock
lock ->
                          IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ PackageDbLock -> IO ()
GhcPkg.unlockPackageDb PackageDbLock
lock
                      (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite))
-> RIO env (PackageDB 'DbReadOnly, Maybe (PackageDB 'DbReadWrite))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageDB 'DbReadOnly
ro_db, Maybe (PackageDB 'DbReadWrite)
forall a. Maybe a
Nothing)
        | SomeBase Dir
db_path <- [SomeBase Dir]
final_stack ]

      PackageDB 'DbReadWrite
to_modify <- case Maybe (PackageDB 'DbReadWrite)
mto_modify of
        Just PackageDB 'DbReadWrite
db -> PackageDB 'DbReadWrite -> RIO env (PackageDB 'DbReadWrite)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageDB 'DbReadWrite
db
        Maybe (PackageDB 'DbReadWrite)
Nothing -> PackageArg
-> Maybe (PackageDB Any) -> RIO env (PackageDB 'DbReadWrite)
forall (mode :: DbMode) env a.
PackageArg -> Maybe (PackageDB mode) -> RIO env a
cannotFindPackage PackageArg
pkgarg Maybe (PackageDB Any)
forall a. Maybe a
Nothing

      (PackageDBStack, DbOpenMode 'DbReadWrite (PackageDB 'DbReadWrite))
-> RIO
     env
     (PackageDBStack, DbOpenMode 'DbReadWrite (PackageDB 'DbReadWrite))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageDBStack
db_stack, PackageDB 'DbReadWrite
-> DbOpenMode 'DbReadWrite (PackageDB 'DbReadWrite)
forall t. t -> DbOpenMode 'DbReadWrite t
GhcPkg.DbOpenReadWrite PackageDB 'DbReadWrite
to_modify)
   where
    -- Parse package db in read-only mode.

    readDatabase :: SomeBase Dir -> RIO env (PackageDB 'GhcPkg.DbReadOnly)
    readDatabase :: SomeBase Dir -> RIO env (PackageDB 'DbReadOnly)
readDatabase = DbOpenMode 'DbReadOnly Any
-> SomeBase Dir -> RIO env (PackageDB 'DbReadOnly)
forall (mode :: DbMode) t env.
HasTerm env =>
DbOpenMode mode t -> SomeBase Dir -> RIO env (PackageDB mode)
readParseDatabase DbOpenMode 'DbReadOnly Any
forall t. DbOpenMode 'DbReadOnly t
GhcPkg.DbOpenReadOnly

  stateSequence :: Monad m => s -> [s -> m (a, s)] -> m ([a], s)
  stateSequence :: forall (m :: * -> *) s a.
Monad m =>
s -> [s -> m (a, s)] -> m ([a], s)
stateSequence s
s []     = ([a], s) -> m ([a], s)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], s
s)
  stateSequence s
s (s -> m (a, s)
m:[s -> m (a, s)]
ms) = do
    (a
a, s
s')   <- s -> m (a, s)
m s
s
    ([a]
as, s
s'') <- s -> [s -> m (a, s)] -> m ([a], s)
forall (m :: * -> *) s a.
Monad m =>
s -> [s -> m (a, s)] -> m ([a], s)
stateSequence s
s' [s -> m (a, s)]
ms
    ([a], s) -> m ([a], s)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as, s
s'')

readParseDatabase ::
     forall mode t env. HasTerm env
  => GhcPkg.DbOpenMode mode t
  -> SomeBase Dir
  -> RIO env (PackageDB mode)
readParseDatabase :: forall (mode :: DbMode) t env.
HasTerm env =>
DbOpenMode mode t -> SomeBase Dir -> RIO env (PackageDB mode)
readParseDatabase DbOpenMode mode t
mode SomeBase Dir
path = do
  Either IOException ([Path Abs Dir], [Path Abs File])
e <- RIO env ([Path Abs Dir], [Path Abs File])
-> RIO env (Either IOException ([Path Abs Dir], [Path Abs File]))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO (RIO env ([Path Abs Dir], [Path Abs File])
 -> RIO env (Either IOException ([Path Abs Dir], [Path Abs File])))
-> RIO env ([Path Abs Dir], [Path Abs File])
-> RIO env (Either IOException ([Path Abs Dir], [Path Abs File]))
forall a b. (a -> b) -> a -> b
$ (forall b. Path b Dir -> RIO env ([Path Abs Dir], [Path Abs File]))
-> SomeBase Dir -> RIO env ([Path Abs Dir], [Path Abs File])
forall t a. (forall b. Path b t -> a) -> SomeBase t -> a
prjSomeBase Path b Dir -> RIO env ([Path Abs Dir], [Path Abs File])
forall b. Path b Dir -> RIO env ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir SomeBase Dir
path
  case Either IOException ([Path Abs Dir], [Path Abs File])
e of
    Left IOException
err
      | IOException -> IOErrorType
ioeGetErrorType IOException
err IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
== IOErrorType
InappropriateType -> do
         -- We provide a limited degree of backwards compatibility for

         -- old single-file style db:

         Maybe (PackageDB mode)
mdb <- DbOpenMode mode t
-> SomeBase Dir -> RIO env (Maybe (PackageDB mode))
forall env (mode :: DbMode) t.
HasTerm env =>
DbOpenMode mode t
-> SomeBase Dir -> RIO env (Maybe (PackageDB mode))
tryReadParseOldFileStyleDatabase DbOpenMode mode t
mode SomeBase Dir
path
         case Maybe (PackageDB mode)
mdb of
           Just PackageDB mode
db -> PackageDB mode -> RIO env (PackageDB mode)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageDB mode
db
           Maybe (PackageDB mode)
Nothing -> GhcPkgPrettyException -> RIO env (PackageDB mode)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (GhcPkgPrettyException -> RIO env (PackageDB mode))
-> GhcPkgPrettyException -> RIO env (PackageDB mode)
forall a b. (a -> b) -> a -> b
$ SomeBase Dir -> GhcPkgPrettyException
SingleFileDBUnsupported SomeBase Dir
path

      | Bool
otherwise -> IO (PackageDB mode) -> RIO env (PackageDB mode)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (PackageDB mode) -> RIO env (PackageDB mode))
-> IO (PackageDB mode) -> RIO env (PackageDB mode)
forall a b. (a -> b) -> a -> b
$ IOException -> IO (PackageDB mode)
forall a. IOException -> IO a
ioError IOException
err
    Right ([Path Abs Dir]
_, [Path Abs File]
fs) -> RIO env (PackageDB mode)
ignore_cache
     where
      confs :: [Path Abs File]
confs = (Path Abs File -> Bool) -> [Path Abs File] -> [Path Abs File]
forall a. (a -> Bool) -> [a] -> [a]
filter Path Abs File -> Bool
isConf [Path Abs File]
fs

      isConf :: Path Abs File -> Bool
      isConf :: Path Abs File -> Bool
isConf Path Abs File
f = case Path Abs File -> Maybe [Char]
forall (m :: * -> *) b. MonadThrow m => Path b File -> m [Char]
fileExtension Path Abs File
f of
        Maybe [Char]
Nothing -> Bool
False
        Just [Char]
ext -> [Char]
ext [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
".conf"

      ignore_cache :: RIO env (PackageDB mode)
      ignore_cache :: RIO env (PackageDB mode)
ignore_cache = 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 going to modify it later.

        DbOpenMode mode PackageDbLock
lock <- IO (DbOpenMode mode PackageDbLock)
-> RIO env (DbOpenMode mode PackageDbLock)
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (DbOpenMode mode PackageDbLock)
 -> RIO env (DbOpenMode mode PackageDbLock))
-> IO (DbOpenMode mode PackageDbLock)
-> RIO env (DbOpenMode mode PackageDbLock)
forall a b. (a -> b) -> a -> b
$
          (t -> IO PackageDbLock)
-> DbOpenMode mode t -> IO (DbOpenMode mode PackageDbLock)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> DbOpenMode mode a -> m (DbOpenMode mode b)
F.mapM (IO PackageDbLock -> t -> IO PackageDbLock
forall a b. a -> b -> a
const (IO PackageDbLock -> t -> IO PackageDbLock)
-> IO PackageDbLock -> t -> IO PackageDbLock
forall a b. (a -> b) -> a -> b
$ [Char] -> IO PackageDbLock
GhcPkg.lockPackageDb ((forall b. Path b File -> [Char]) -> SomeBase File -> [Char]
forall t a. (forall b. Path b t -> a) -> SomeBase t -> a
prjSomeBase Path b File -> [Char]
forall b. Path b File -> [Char]
forall b t. Path b t -> [Char]
toFilePath SomeBase File
cache)) DbOpenMode mode t
mode
        [InstalledPackageInfo]
pkgs <- (Path Abs File -> RIO env InstalledPackageInfo)
-> [Path Abs File] -> RIO env [InstalledPackageInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Path Abs File -> RIO env InstalledPackageInfo
forall env.
HasTerm env =>
Path Abs File -> RIO env InstalledPackageInfo
parseSingletonPackageConf [Path Abs File]
confs
        [InstalledPackageInfo]
-> DbOpenMode mode PackageDbLock -> RIO env (PackageDB mode)
mkPackageDB [InstalledPackageInfo]
pkgs DbOpenMode mode PackageDbLock
lock
 where
  cache :: SomeBase File
cache = (forall b. Path b Dir -> Path b File)
-> SomeBase Dir -> SomeBase File
forall t t'.
(forall b. Path b t -> Path b t') -> SomeBase t -> SomeBase t'
mapSomeBase (Path b Dir -> Path Rel File -> Path b File
forall b t. Path b Dir -> Path Rel t -> Path b t
P.</> Path Rel File
relFilePackageCache) SomeBase Dir
path

  mkPackageDB ::
       [InstalledPackageInfo]
    -> GhcPkg.DbOpenMode mode GhcPkg.PackageDbLock
    -> RIO env (PackageDB mode)
  mkPackageDB :: [InstalledPackageInfo]
-> DbOpenMode mode PackageDbLock -> RIO env (PackageDB mode)
mkPackageDB [InstalledPackageInfo]
pkgs DbOpenMode mode PackageDbLock
lock =
    PackageDB mode -> RIO env (PackageDB mode)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageDB
      { location :: SomeBase Dir
location = SomeBase Dir
path
      , packageDbLock :: DbOpenMode mode PackageDbLock
packageDbLock = DbOpenMode mode PackageDbLock
lock
      , packages :: [InstalledPackageInfo]
packages = [InstalledPackageInfo]
pkgs
      }

parseSingletonPackageConf ::
     HasTerm env
  => Path Abs File
  -> RIO env InstalledPackageInfo
parseSingletonPackageConf :: forall env.
HasTerm env =>
Path Abs File -> RIO env InstalledPackageInfo
parseSingletonPackageConf Path Abs File
file = do
  [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyDebugL
    [ [Char] -> StyleDoc
flow [Char]
"Reading package config:"
    , Path Abs File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty Path Abs File
file
    ]
  [Char] -> RIO env ByteString
forall (m :: * -> *). MonadIO m => [Char] -> m ByteString
BS.readFile (Path Abs File -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path Abs File
file) RIO env ByteString
-> (ByteString -> RIO env InstalledPackageInfo)
-> RIO env InstalledPackageInfo
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((InstalledPackageInfo, [[Char]]) -> InstalledPackageInfo)
-> RIO env (InstalledPackageInfo, [[Char]])
-> RIO env InstalledPackageInfo
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (InstalledPackageInfo, [[Char]]) -> InstalledPackageInfo
forall a b. (a, b) -> a
fst (RIO env (InstalledPackageInfo, [[Char]])
 -> RIO env InstalledPackageInfo)
-> (ByteString -> RIO env (InstalledPackageInfo, [[Char]]))
-> ByteString
-> RIO env InstalledPackageInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> RIO env (InstalledPackageInfo, [[Char]])
forall env. ByteString -> RIO env (InstalledPackageInfo, [[Char]])
parsePackageInfo

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

-- Workaround for old single-file style package dbs


-- Single-file style package dbs have been deprecated for some time, but

-- it turns out that Cabal was using them in one place. So this code is for a

-- workaround to allow older Cabal versions to use this newer ghc.


-- We check if the file db contains just "[]" and if so, we look for a new

-- dir-style db in path.d/, ie in a dir next to the given file.

-- We cannot just replace the file with a new dir style since Cabal still

-- assumes it's a file and tries to overwrite with 'writeFile'.


-- ghc itself also cooperates in this workaround


tryReadParseOldFileStyleDatabase ::
     HasTerm env
  => GhcPkg.DbOpenMode mode t
  -> SomeBase Dir
  -> RIO env (Maybe (PackageDB mode))
tryReadParseOldFileStyleDatabase :: forall env (mode :: DbMode) t.
HasTerm env =>
DbOpenMode mode t
-> SomeBase Dir -> RIO env (Maybe (PackageDB mode))
tryReadParseOldFileStyleDatabase DbOpenMode mode t
mode SomeBase Dir
path = do
  -- assumes we've already established that path exists and is not a dir

  [Char]
content <- IO [Char] -> RIO env [Char]
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Char] -> RIO env [Char]) -> IO [Char] -> RIO env [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
readFile ((forall b. Path b Dir -> [Char]) -> SomeBase Dir -> [Char]
forall t a. (forall b. Path b t -> a) -> SomeBase t -> a
prjSomeBase Path b Dir -> [Char]
forall b. Path b Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath SomeBase Dir
path) IO [Char] -> (IOException -> IO [Char]) -> IO [Char]
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (IOException -> m a) -> m a
`catchIO` \IOException
_ -> [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
""
  if Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
2 [Char]
content [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"[]"
    then do
      SomeBase Dir
path_dir <- SomeBase Dir -> RIO env (SomeBase Dir)
forall env. SomeBase Dir -> RIO env (SomeBase Dir)
adjustOldDatabasePath SomeBase Dir
path
      [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyWarnL
        [ [Char] -> StyleDoc
flow [Char]
"Ignoring old file-style db and trying"
        , SomeBase Dir -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty SomeBase Dir
path_dir
        ]
      Bool
direxists <- (forall b. Path b Dir -> RIO env Bool)
-> SomeBase Dir -> RIO env Bool
forall t a. (forall b. Path b t -> a) -> SomeBase t -> a
prjSomeBase Path b Dir -> RIO env Bool
forall b. Path b Dir -> RIO env Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist SomeBase Dir
path_dir
      if Bool
direxists
        then do
          PackageDB mode
db <- DbOpenMode mode t -> SomeBase Dir -> RIO env (PackageDB mode)
forall (mode :: DbMode) t env.
HasTerm env =>
DbOpenMode mode t -> SomeBase Dir -> RIO env (PackageDB mode)
readParseDatabase DbOpenMode mode t
mode SomeBase Dir
path_dir
          -- but pretend it was at the original location

          Maybe (PackageDB mode) -> RIO env (Maybe (PackageDB mode))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (PackageDB mode) -> RIO env (Maybe (PackageDB mode)))
-> Maybe (PackageDB mode) -> RIO env (Maybe (PackageDB mode))
forall a b. (a -> b) -> a -> b
$ PackageDB mode -> Maybe (PackageDB mode)
forall a. a -> Maybe a
Just PackageDB mode
db { location         = path }
         else do
           DbOpenMode mode PackageDbLock
lock <- DbOpenMode mode t
-> (t -> RIO env PackageDbLock)
-> RIO env (DbOpenMode mode PackageDbLock)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
F.forM DbOpenMode mode t
mode ((t -> RIO env PackageDbLock)
 -> RIO env (DbOpenMode mode PackageDbLock))
-> (t -> RIO env PackageDbLock)
-> RIO env (DbOpenMode mode PackageDbLock)
forall a b. (a -> b) -> a -> b
$ \t
_ -> do
             (forall b. Path b Dir -> RIO env ()) -> SomeBase Dir -> RIO env ()
forall t a. (forall b. Path b t -> a) -> SomeBase t -> a
prjSomeBase (Bool -> Path b Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Bool -> Path b Dir -> m ()
createDirIfMissing Bool
True) SomeBase Dir
path_dir
             IO PackageDbLock -> RIO env PackageDbLock
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO PackageDbLock -> RIO env PackageDbLock)
-> IO PackageDbLock -> RIO env PackageDbLock
forall a b. (a -> b) -> a -> b
$ [Char] -> IO PackageDbLock
GhcPkg.lockPackageDb ([Char] -> IO PackageDbLock) -> [Char] -> IO PackageDbLock
forall a b. (a -> b) -> a -> b
$
               (forall b. Path b Dir -> [Char]) -> SomeBase Dir -> [Char]
forall t a. (forall b. Path b t -> a) -> SomeBase t -> a
prjSomeBase (Path b File -> [Char]
forall b t. Path b t -> [Char]
toFilePath (Path b File -> [Char])
-> (Path b Dir -> Path b File) -> Path b Dir -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Path b Dir -> Path Rel File -> Path b File
forall b t. Path b Dir -> Path Rel t -> Path b t
P.</> Path Rel File
relFilePackageCache)) SomeBase Dir
path_dir
           Maybe (PackageDB mode) -> RIO env (Maybe (PackageDB mode))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (PackageDB mode) -> RIO env (Maybe (PackageDB mode)))
-> Maybe (PackageDB mode) -> RIO env (Maybe (PackageDB mode))
forall a b. (a -> b) -> a -> b
$ PackageDB mode -> Maybe (PackageDB mode)
forall a. a -> Maybe a
Just PackageDB
             { location :: SomeBase Dir
location         = SomeBase Dir
path
             , packageDbLock :: DbOpenMode mode PackageDbLock
packageDbLock    = DbOpenMode mode PackageDbLock
lock
             , packages :: [InstalledPackageInfo]
packages         = []
             }

    -- if the path is not a file, or is not an empty db then we fail

    else Maybe (PackageDB mode) -> RIO env (Maybe (PackageDB mode))
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (PackageDB mode)
forall a. Maybe a
Nothing

adjustOldFileStylePackageDB :: PackageDB mode -> RIO env (PackageDB mode)
adjustOldFileStylePackageDB :: forall (mode :: DbMode) env.
PackageDB mode -> RIO env (PackageDB mode)
adjustOldFileStylePackageDB PackageDB mode
db = do
  -- assumes we have not yet established if it's an old style or not

  Maybe [Char]
mcontent <- IO (Maybe [Char]) -> RIO env (Maybe [Char])
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe [Char]) -> RIO env (Maybe [Char]))
-> IO (Maybe [Char]) -> RIO env (Maybe [Char])
forall a b. (a -> b) -> a -> b
$
    ([Char] -> Maybe [Char]) -> IO [Char] -> IO (Maybe [Char])
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> IO [Char]
readFile ((forall b. Path b Dir -> [Char]) -> SomeBase Dir -> [Char]
forall t a. (forall b. Path b t -> a) -> SomeBase t -> a
prjSomeBase Path b Dir -> [Char]
forall b. Path b Dir -> [Char]
forall b t. Path b t -> [Char]
toFilePath PackageDB mode
db.location)) IO (Maybe [Char])
-> (IOException -> IO (Maybe [Char])) -> IO (Maybe [Char])
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (IOException -> m a) -> m a
`catchIO` \IOException
_ -> Maybe [Char] -> IO (Maybe [Char])
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [Char]
forall a. Maybe a
Nothing
  case ShowS -> Maybe [Char] -> Maybe [Char]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
2) Maybe [Char]
mcontent of
    -- it is an old style and empty db, so look for a dir kind in location.d/

    Just [Char]
"[]" -> do
      SomeBase Dir
adjustedDatabasePath <- SomeBase Dir -> RIO env (SomeBase Dir)
forall env. SomeBase Dir -> RIO env (SomeBase Dir)
adjustOldDatabasePath PackageDB mode
db.location
      PackageDB mode -> RIO env (PackageDB mode)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageDB mode
db { location = adjustedDatabasePath }
    -- it is old style but not empty, we have to bail

    Just [Char]
_ -> GhcPkgPrettyException -> RIO env (PackageDB mode)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (GhcPkgPrettyException -> RIO env (PackageDB mode))
-> GhcPkgPrettyException -> RIO env (PackageDB mode)
forall a b. (a -> b) -> a -> b
$ SomeBase Dir -> GhcPkgPrettyException
SingleFileDBUnsupported PackageDB mode
db.location
    -- probably not old style, carry on as normal

    Maybe [Char]
Nothing -> PackageDB mode -> RIO env (PackageDB mode)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageDB mode
db

adjustOldDatabasePath :: SomeBase Dir -> RIO env (SomeBase Dir)
adjustOldDatabasePath :: forall env. SomeBase Dir -> RIO env (SomeBase Dir)
adjustOldDatabasePath = (forall b. Path b Dir -> RIO env (SomeBase Dir))
-> SomeBase Dir -> RIO env (SomeBase Dir)
forall t a. (forall b. Path b t -> a) -> SomeBase t -> a
prjSomeBase Path b Dir -> RIO env (SomeBase Dir)
forall b. Path b Dir -> RIO env (SomeBase Dir)
forall {m :: * -> *} {b} {t}.
MonadIO m =>
Path b t -> m (SomeBase Dir)
addDToDirName
 where
  addDToDirName :: Path b t -> m (SomeBase Dir)
addDToDirName Path b t
dir = do
    let dirNameWithD :: [Char]
dirNameWithD = Path b t -> [Char]
forall b t. Path b t -> [Char]
toFilePath Path b t
dir [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
".d"
    m (SomeBase Dir)
-> (SomeBase Dir -> m (SomeBase Dir))
-> Maybe (SomeBase Dir)
-> m (SomeBase Dir)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (GhcPkgPrettyException -> m (SomeBase Dir)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (GhcPkgPrettyException -> m (SomeBase Dir))
-> GhcPkgPrettyException -> m (SomeBase Dir)
forall a b. (a -> b) -> a -> b
$ [Char] -> GhcPkgPrettyException
CannotParseDirectoryWithDBug [Char]
dirNameWithD)
      SomeBase Dir -> m (SomeBase Dir)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ([Char] -> Maybe (SomeBase Dir)
forall (m :: * -> *). MonadThrow m => [Char] -> m (SomeBase Dir)
parseSomeDir [Char]
dirNameWithD)

parsePackageInfo :: BS.ByteString -> RIO env (InstalledPackageInfo, [String])
parsePackageInfo :: forall env. ByteString -> RIO env (InstalledPackageInfo, [[Char]])
parsePackageInfo ByteString
str =
  case ByteString
-> Either (NonEmpty [Char]) ([[Char]], InstalledPackageInfo)
parseInstalledPackageInfo ByteString
str of
    Right ([[Char]]
warnings, InstalledPackageInfo
ok) -> (InstalledPackageInfo, [[Char]])
-> RIO env (InstalledPackageInfo, [[Char]])
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstalledPackageInfo -> InstalledPackageInfo
mungePackageInfo InstalledPackageInfo
ok, [[Char]]
ws)
     where
      ws :: [[Char]]
ws = [ [Char]
msg | [Char]
msg <- [[Char]]
warnings
                 , Bool -> Bool
not ([Char]
"Unrecognized field pkgroot" [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char]
msg) ]
    Left NonEmpty [Char]
err -> GhcPkgPrettyException -> RIO env (InstalledPackageInfo, [[Char]])
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (GhcPkgPrettyException -> RIO env (InstalledPackageInfo, [[Char]]))
-> GhcPkgPrettyException
-> RIO env (InstalledPackageInfo, [[Char]])
forall a b. (a -> b) -> a -> b
$ [Char] -> GhcPkgPrettyException
ParsePackageInfoExceptions ([[Char]] -> [Char]
unlines (NonEmpty [Char] -> [[Char]]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList NonEmpty [Char]
err))

mungePackageInfo :: InstalledPackageInfo -> InstalledPackageInfo
mungePackageInfo :: InstalledPackageInfo -> InstalledPackageInfo
mungePackageInfo InstalledPackageInfo
ipi = InstalledPackageInfo
ipi

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

-- Making changes to a package database


newtype DBOp = RemovePackage InstalledPackageInfo

changeNewDB ::
     HasTerm env
  => [DBOp]
  -> PackageDB 'GhcPkg.DbReadWrite
  -> RIO env ()
changeNewDB :: forall env.
HasTerm env =>
[DBOp] -> PackageDB 'DbReadWrite -> RIO env ()
changeNewDB [DBOp]
cmds PackageDB 'DbReadWrite
new_db = do
  PackageDB 'DbReadWrite
new_db' <- PackageDB 'DbReadWrite -> RIO env (PackageDB 'DbReadWrite)
forall (mode :: DbMode) env.
PackageDB mode -> RIO env (PackageDB mode)
adjustOldFileStylePackageDB PackageDB 'DbReadWrite
new_db
  (forall b. Path b Dir -> RIO env ()) -> SomeBase Dir -> RIO env ()
forall t a. (forall b. Path b t -> a) -> SomeBase t -> a
prjSomeBase (Bool -> Path b Dir -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Bool -> Path b Dir -> m ()
createDirIfMissing Bool
True) PackageDB 'DbReadWrite
new_db'.location
  [DBOp] -> PackageDB 'DbReadWrite -> RIO env ()
forall env.
HasTerm env =>
[DBOp] -> PackageDB 'DbReadWrite -> RIO env ()
changeDBDir' [DBOp]
cmds PackageDB 'DbReadWrite
new_db'

changeDBDir' ::
     HasTerm env
  => [DBOp]
  -> PackageDB 'GhcPkg.DbReadWrite
  -> RIO env ()
changeDBDir' :: forall env.
HasTerm env =>
[DBOp] -> PackageDB 'DbReadWrite -> RIO env ()
changeDBDir' [DBOp]
cmds PackageDB 'DbReadWrite
db = do
  (DBOp -> RIO env ()) -> [DBOp] -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DBOp -> RIO env ()
do_cmd [DBOp]
cmds
  case PackageDB 'DbReadWrite
db.packageDbLock of
    GhcPkg.DbOpenReadWrite PackageDbLock
lock -> IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ PackageDbLock -> IO ()
GhcPkg.unlockPackageDb PackageDbLock
lock
 where
  do_cmd :: DBOp -> RIO env ()
do_cmd (RemovePackage InstalledPackageInfo
p) = do
    let relFileConfName :: [Char]
relFileConfName = UnitId -> [Char]
forall a. Pretty a => a -> [Char]
display (InstalledPackageInfo -> UnitId
installedUnitId InstalledPackageInfo
p) [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
".conf"
    Path Rel File
relFileConf <- RIO env (Path Rel File)
-> (Path Rel File -> RIO env (Path Rel File))
-> Maybe (Path Rel File)
-> RIO env (Path Rel File)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (GhcPkgPrettyException -> RIO env (Path Rel File)
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (GhcPkgPrettyException -> RIO env (Path Rel File))
-> GhcPkgPrettyException -> RIO env (Path Rel File)
forall a b. (a -> b) -> a -> b
$ [Char] -> GhcPkgPrettyException
CannotParseRelFileBug [Char]
relFileConfName)
      Path Rel File -> RIO env (Path Rel File)
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      ([Char] -> Maybe (Path Rel File)
forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile [Char]
relFileConfName)
    let file :: SomeBase File
file = (forall b. Path b Dir -> Path b File)
-> SomeBase Dir -> SomeBase File
forall t t'.
(forall b. Path b t -> Path b t') -> SomeBase t -> SomeBase t'
mapSomeBase (Path b Dir -> Path Rel File -> Path b File
forall b t. Path b Dir -> Path Rel t -> Path b t
P.</> Path Rel File
relFileConf) PackageDB 'DbReadWrite
db.location
    [StyleDoc] -> RIO env ()
forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
[StyleDoc] -> m ()
prettyDebugL
      [ StyleDoc
"Removing"
      , SomeBase File -> StyleDoc
forall a. Pretty a => a -> StyleDoc
pretty SomeBase File
file
      ]
    SomeBase File -> RIO env ()
forall env. SomeBase File -> RIO env ()
removeFileSafe SomeBase File
file

unregisterPackages ::
     forall env. HasTerm env
  => Path Abs Dir
     -- ^ Path to the global package database.

  -> [PackageArg]
  -> Path Abs Dir
     -- ^ Path to the package database.

  -> RIO env ()
unregisterPackages :: forall env.
HasTerm env =>
Path Abs Dir -> [PackageArg] -> Path Abs Dir -> RIO env ()
unregisterPackages Path Abs Dir
globalDb [PackageArg]
pkgargs Path Abs Dir
pkgDb = do
  [(PackageDB 'DbReadWrite, [UnitId])]
pkgsByPkgDBs <- ([(PackageDB 'DbReadWrite, [UnitId])]
 -> PackageArg -> RIO env [(PackageDB 'DbReadWrite, [UnitId])])
-> [(PackageDB 'DbReadWrite, [UnitId])]
-> [PackageArg]
-> RIO env [(PackageDB 'DbReadWrite, [UnitId])]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
F.foldlM ([(PackageDB 'DbReadWrite, [UnitId])]
-> [(PackageDB 'DbReadWrite, [UnitId])]
-> PackageArg
-> RIO env [(PackageDB 'DbReadWrite, [UnitId])]
getPkgsByPkgDBs []) [] [PackageArg]
pkgargs
  [(PackageDB 'DbReadWrite, [UnitId])]
-> ((PackageDB 'DbReadWrite, [UnitId]) -> RIO env ()) -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(PackageDB 'DbReadWrite, [UnitId])]
pkgsByPkgDBs (PackageDB 'DbReadWrite, [UnitId]) -> RIO env ()
unregisterPackages'
 where
  -- Update a list of 'packages by package database' for a package. Assumes that

  -- a package to be unregistered is in no more than one database.

  getPkgsByPkgDBs :: [(PackageDB GhcPkg.DbReadWrite, [UnitId])]
                  -- ^ List of considered 'packages by package database'

                  -> [(PackageDB GhcPkg.DbReadWrite, [UnitId])]
                  -- ^ List of to be considered 'packages by package database'

                  -> PackageArg
                  -- Package to update

                  -> RIO env [(PackageDB GhcPkg.DbReadWrite, [UnitId])]
  -- No more 'packages by package database' to consider? We need to try to get

  -- another package database.

  getPkgsByPkgDBs :: [(PackageDB 'DbReadWrite, [UnitId])]
-> [(PackageDB 'DbReadWrite, [UnitId])]
-> PackageArg
-> RIO env [(PackageDB 'DbReadWrite, [UnitId])]
getPkgsByPkgDBs [(PackageDB 'DbReadWrite, [UnitId])]
pkgsByPkgDBs [] PackageArg
pkgarg =
    Path Abs Dir
-> PackageArg
-> Path Abs Dir
-> RIO
     env
     (PackageDBStack, DbOpenMode 'DbReadWrite (PackageDB 'DbReadWrite),
      PackageDBStack)
forall env.
HasTerm env =>
Path Abs Dir
-> PackageArg
-> Path Abs Dir
-> RIO
     env
     (PackageDBStack, DbOpenMode 'DbReadWrite (PackageDB 'DbReadWrite),
      PackageDBStack)
getPkgDatabases Path Abs Dir
globalDb PackageArg
pkgarg Path Abs Dir
pkgDb RIO
  env
  (PackageDBStack, DbOpenMode 'DbReadWrite (PackageDB 'DbReadWrite),
   PackageDBStack)
-> ((PackageDBStack,
     DbOpenMode 'DbReadWrite (PackageDB 'DbReadWrite), PackageDBStack)
    -> RIO env [(PackageDB 'DbReadWrite, [UnitId])])
-> RIO env [(PackageDB 'DbReadWrite, [UnitId])]
forall a b. RIO env a -> (a -> RIO env b) -> RIO env b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (PackageDBStack
_, GhcPkg.DbOpenReadWrite (PackageDB 'DbReadWrite
db :: PackageDB GhcPkg.DbReadWrite), PackageDBStack
_) -> do
        [UnitId]
pks <- do
          let pkgs :: [InstalledPackageInfo]
pkgs = PackageDB 'DbReadWrite
db.packages
              ps :: [InstalledPackageInfo]
ps = PackageArg -> [InstalledPackageInfo] -> [InstalledPackageInfo]
findPackage PackageArg
pkgarg [InstalledPackageInfo]
pkgs
          -- This shouldn't happen if getPkgsByPkgDBs picks the DB correctly.

          Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([InstalledPackageInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InstalledPackageInfo]
ps) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ PackageArg -> Maybe (PackageDB 'DbReadWrite) -> RIO env ()
forall (mode :: DbMode) env a.
PackageArg -> Maybe (PackageDB mode) -> RIO env a
cannotFindPackage PackageArg
pkgarg (Maybe (PackageDB 'DbReadWrite) -> RIO env ())
-> Maybe (PackageDB 'DbReadWrite) -> RIO env ()
forall a b. (a -> b) -> a -> b
$ PackageDB 'DbReadWrite -> Maybe (PackageDB 'DbReadWrite)
forall a. a -> Maybe a
Just PackageDB 'DbReadWrite
db
          [UnitId] -> RIO env [UnitId]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((InstalledPackageInfo -> UnitId)
-> [InstalledPackageInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map InstalledPackageInfo -> UnitId
installedUnitId [InstalledPackageInfo]
ps)
        let pkgsByPkgDB :: (PackageDB 'DbReadWrite, [UnitId])
pkgsByPkgDB = (PackageDB 'DbReadWrite
db, [UnitId]
pks)
        [(PackageDB 'DbReadWrite, [UnitId])]
-> RIO env [(PackageDB 'DbReadWrite, [UnitId])]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((PackageDB 'DbReadWrite, [UnitId])
pkgsByPkgDB (PackageDB 'DbReadWrite, [UnitId])
-> [(PackageDB 'DbReadWrite, [UnitId])]
-> [(PackageDB 'DbReadWrite, [UnitId])]
forall a. a -> [a] -> [a]
: [(PackageDB 'DbReadWrite, [UnitId])]
pkgsByPkgDBs)
  -- Consider the next 'packages by package database' in the list of ones to

  -- consider.

  getPkgsByPkgDBs [(PackageDB 'DbReadWrite, [UnitId])]
pkgsByPkgDBs ( (PackageDB 'DbReadWrite, [UnitId])
pkgsByPkgDB : [(PackageDB 'DbReadWrite, [UnitId])]
pkgsByPkgDBs') PackageArg
pkgarg = do
    let (PackageDB 'DbReadWrite
db, [UnitId]
pks') = (PackageDB 'DbReadWrite, [UnitId])
pkgsByPkgDB
        pkgs :: [InstalledPackageInfo]
pkgs = PackageDB 'DbReadWrite
db.packages
        ps :: [InstalledPackageInfo]
ps = PackageArg -> [InstalledPackageInfo] -> [InstalledPackageInfo]
findPackage PackageArg
pkgarg [InstalledPackageInfo]
pkgs
        pks :: [UnitId]
pks = (InstalledPackageInfo -> UnitId)
-> [InstalledPackageInfo] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map InstalledPackageInfo -> UnitId
installedUnitId [InstalledPackageInfo]
ps
        pkgByPkgDB' :: (PackageDB 'DbReadWrite, [UnitId])
pkgByPkgDB' = (PackageDB 'DbReadWrite
db, [UnitId]
pks [UnitId] -> [UnitId] -> [UnitId]
forall a. Semigroup a => a -> a -> a
<> [UnitId]
pks')
    if [InstalledPackageInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InstalledPackageInfo]
ps
      then
        -- Not found in the package database? Add the package database to those

        -- considered and try with the remaining package databases to consider.

        [(PackageDB 'DbReadWrite, [UnitId])]
-> [(PackageDB 'DbReadWrite, [UnitId])]
-> PackageArg
-> RIO env [(PackageDB 'DbReadWrite, [UnitId])]
getPkgsByPkgDBs ( (PackageDB 'DbReadWrite, [UnitId])
pkgsByPkgDB (PackageDB 'DbReadWrite, [UnitId])
-> [(PackageDB 'DbReadWrite, [UnitId])]
-> [(PackageDB 'DbReadWrite, [UnitId])]
forall a. a -> [a] -> [a]
: [(PackageDB 'DbReadWrite, [UnitId])]
pkgsByPkgDBs ) [(PackageDB 'DbReadWrite, [UnitId])]
pkgsByPkgDBs' PackageArg
pkgarg
      else
        -- Found in the package database? Add to the list of packages to be

        -- unregistered from that package database. TO DO: Perhaps check not

        -- already in that list for better error messages when there are

        -- duplicated requests to unregister.

        [(PackageDB 'DbReadWrite, [UnitId])]
-> RIO env [(PackageDB 'DbReadWrite, [UnitId])]
forall a. a -> RIO env a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(PackageDB 'DbReadWrite, [UnitId])]
pkgsByPkgDBs [(PackageDB 'DbReadWrite, [UnitId])]
-> [(PackageDB 'DbReadWrite, [UnitId])]
-> [(PackageDB 'DbReadWrite, [UnitId])]
forall a. Semigroup a => a -> a -> a
<> ((PackageDB 'DbReadWrite, [UnitId])
pkgByPkgDB' (PackageDB 'DbReadWrite, [UnitId])
-> [(PackageDB 'DbReadWrite, [UnitId])]
-> [(PackageDB 'DbReadWrite, [UnitId])]
forall a. a -> [a] -> [a]
: [(PackageDB 'DbReadWrite, [UnitId])]
pkgsByPkgDBs'))

  unregisterPackages' :: (PackageDB GhcPkg.DbReadWrite, [UnitId]) -> RIO env ()
  unregisterPackages' :: (PackageDB 'DbReadWrite, [UnitId]) -> RIO env ()
unregisterPackages' (PackageDB 'DbReadWrite
db, [UnitId]
pks) = do
    let pkgs :: [InstalledPackageInfo]
pkgs = PackageDB 'DbReadWrite
db.packages
        cmds :: [DBOp]
cmds = [ InstalledPackageInfo -> DBOp
RemovePackage InstalledPackageInfo
pkg
               | InstalledPackageInfo
pkg <- [InstalledPackageInfo]
pkgs, InstalledPackageInfo -> UnitId
installedUnitId InstalledPackageInfo
pkg UnitId -> [UnitId] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UnitId]
pks
               ]
        new_db :: PackageDB 'DbReadWrite
new_db = PackageDB 'DbReadWrite
db{ packages = pkgs' }
         where
          deleteFirstsBy' :: (a -> b -> Bool) -> [a] -> [b] -> [a]
          deleteFirstsBy' :: forall a b. (a -> b -> Bool) -> [a] -> [b] -> [a]
deleteFirstsBy' a -> b -> Bool
eq = ([a] -> b -> [a]) -> [a] -> [b] -> [a]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((a -> b -> Bool) -> [a] -> b -> [a]
forall a b. (a -> b -> Bool) -> [a] -> b -> [a]
deleteBy' a -> b -> Bool
eq)

          deleteBy' :: (a -> b -> Bool) -> [a] -> b -> [a]
          deleteBy' :: forall a b. (a -> b -> Bool) -> [a] -> b -> [a]
deleteBy' a -> b -> Bool
_ [] b
_ = []
          deleteBy' a -> b -> Bool
eq (a
y:[a]
ys) b
x = if a
y a -> b -> Bool
`eq` b
x then [a]
ys else a
y a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> b -> Bool) -> [a] -> b -> [a]
forall a b. (a -> b -> Bool) -> [a] -> b -> [a]
deleteBy' a -> b -> Bool
eq [a]
ys b
x

          pkgs' :: [InstalledPackageInfo]
pkgs' = (InstalledPackageInfo -> UnitId -> Bool)
-> [InstalledPackageInfo] -> [UnitId] -> [InstalledPackageInfo]
forall a b. (a -> b -> Bool) -> [a] -> [b] -> [a]
deleteFirstsBy' (\InstalledPackageInfo
p1 UnitId
p2 -> InstalledPackageInfo -> UnitId
installedUnitId InstalledPackageInfo
p1 UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
p2) [InstalledPackageInfo]
pkgs [UnitId]
pks
    -- Use changeNewDB, rather than changeDB, to avoid duplicating

    -- updateInternalDB db cmds

    [DBOp] -> PackageDB 'DbReadWrite -> RIO env ()
forall env.
HasTerm env =>
[DBOp] -> PackageDB 'DbReadWrite -> RIO env ()
changeNewDB [DBOp]
cmds PackageDB 'DbReadWrite
new_db

findPackage :: PackageArg -> [InstalledPackageInfo] -> [InstalledPackageInfo]
findPackage :: PackageArg -> [InstalledPackageInfo] -> [InstalledPackageInfo]
findPackage PackageArg
pkgarg = (InstalledPackageInfo -> Bool)
-> [InstalledPackageInfo] -> [InstalledPackageInfo]
forall a. (a -> Bool) -> [a] -> [a]
filter (PackageArg
pkgarg `matchesPkg`)

cannotFindPackage :: PackageArg -> Maybe (PackageDB mode) -> RIO env a
cannotFindPackage :: forall (mode :: DbMode) env a.
PackageArg -> Maybe (PackageDB mode) -> RIO env a
cannotFindPackage PackageArg
pkgarg Maybe (PackageDB mode)
mdb =
  GhcPkgPrettyException -> RIO env a
forall e (m :: * -> *) a.
(Exception e, MonadIO m, Pretty e) =>
e -> m a
prettyThrowIO (GhcPkgPrettyException -> RIO env a)
-> GhcPkgPrettyException -> RIO env a
forall a b. (a -> b) -> a -> b
$ PackageArg -> Maybe (SomeBase Dir) -> GhcPkgPrettyException
CannotFindPackage PackageArg
pkgarg ((.location) (PackageDB mode -> SomeBase Dir)
-> Maybe (PackageDB mode) -> Maybe (SomeBase Dir)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (PackageDB mode)
mdb)

matches :: GlobPackageIdentifier -> MungedPackageId -> Bool
GlobPackageIdentifier MungedPackageName
pn matches :: GlobPackageIdentifier -> MungedPackageId -> Bool
`matches` MungedPackageId
pid' = MungedPackageName
pn MungedPackageName -> MungedPackageName -> Bool
forall a. Eq a => a -> a -> Bool
== MungedPackageId -> MungedPackageName
mungedName MungedPackageId
pid'
ExactPackageIdentifier MungedPackageId
pid `matches` MungedPackageId
pid' =
     MungedPackageId -> MungedPackageName
mungedName MungedPackageId
pid MungedPackageName -> MungedPackageName -> Bool
forall a. Eq a => a -> a -> Bool
== MungedPackageId -> MungedPackageName
mungedName MungedPackageId
pid'
  Bool -> Bool -> Bool
&& (  MungedPackageId -> Version
mungedVersion MungedPackageId
pid Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== MungedPackageId -> Version
mungedVersion MungedPackageId
pid'
     Bool -> Bool -> Bool
|| MungedPackageId -> Version
mungedVersion MungedPackageId
pid Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
nullVersion
     )

matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
(Id GlobPackageIdentifier
pid)        matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
`matchesPkg` InstalledPackageInfo
pkg = GlobPackageIdentifier
pid GlobPackageIdentifier -> MungedPackageId -> Bool
`matches` InstalledPackageInfo -> MungedPackageId
forall pkg. HasMungedPackageId pkg => pkg -> MungedPackageId
mungedId InstalledPackageInfo
pkg
(IUId UnitId
ipid)     `matchesPkg` InstalledPackageInfo
pkg = UnitId
ipid UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== InstalledPackageInfo -> UnitId
installedUnitId InstalledPackageInfo
pkg
(Substring [Char]
_ [Char] -> Bool
m) `matchesPkg` InstalledPackageInfo
pkg = [Char] -> Bool
m (MungedPackageId -> [Char]
forall a. Pretty a => a -> [Char]
display (InstalledPackageInfo -> MungedPackageId
forall pkg. HasMungedPackageId pkg => pkg -> MungedPackageId
mungedId InstalledPackageInfo
pkg))

-- removeFileSave doesn't throw an exceptions, if the file is already deleted

removeFileSafe :: SomeBase File -> RIO env ()
removeFileSafe :: forall env. SomeBase File -> RIO env ()
removeFileSafe SomeBase File
fn = do
  (forall b. Path b File -> RIO env ())
-> SomeBase File -> RIO env ()
forall t a. (forall b. Path b t -> a) -> SomeBase t -> a
prjSomeBase Path b File -> RIO env ()
forall b. Path b File -> RIO env ()
forall (m :: * -> *) b. MonadIO m => Path b File -> m ()
removeFile SomeBase File
fn RIO env () -> (IOException -> RIO env ()) -> RIO env ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (IOException -> m a) -> m a
`catchIO` \ IOException
e ->
    Bool -> RIO env () -> RIO env ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (IOException -> Bool
isDoesNotExistError IOException
e) (RIO env () -> RIO env ()) -> RIO env () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ IOException -> IO ()
forall a. IOException -> IO a
ioError IOException
e