content: {-# LANGUAGE NoImplicitPrelude   #-}
  {-# LANGUAGE OverloadedRecordDot #-}
  {-# LANGUAGE OverloadedStrings   #-}
  
  {-|
  Module      : Stack.GhcPkg
  Description : Functions for the GHC package database.
  License     : BSD-3-Clause
  
  Functions for the GHC package database.
  -}
  
  module Stack.GhcPkg
    ( createDatabase
    , findGhcPkgField
    , getGlobalDB
    , ghcPkg
    , ghcPkgPathEnvVar
    , mkGhcPackagePath
    , unregisterGhcPkgIds
    ) where
  
  import qualified Data.ByteString.Char8 as S8
  import qualified Data.ByteString.Lazy as BL
  import qualified Data.List as L
  import qualified Data.Text as T
  import qualified Data.Text.Encoding as T
  import           GHC.Utils.GhcPkg.Main.Compat ( ghcPkgUnregisterForce )
  import           Path ( (</>), parent )
  import           Path.Extra ( toFilePathNoTrailingSep )
  import           Path.IO
                     ( doesDirExist, doesFileExist, ensureDir, resolveDir' )
  import           RIO.Process ( HasProcessContext, proc, readProcess_ )
  import           Stack.Constants ( relFilePackageCache )
  import           Stack.Prelude
  import           Stack.Types.Compiler ( WhichCompiler (..) )
  import           Stack.Types.CompilerPaths
                     ( CompilerPaths (..), GhcPkgExe (..), HasCompiler
                     , compilerPathsL
                     )
  import           Stack.Types.GhcPkgExe ( GhcPkgPrettyException (..) )
  import           Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdString )
  import           System.FilePath ( searchPathSeparator )
  
  -- | Get the global package database
  getGlobalDB ::
       (HasProcessContext env, HasTerm env)
    => GhcPkgExe
    -> RIO env (Path Abs Dir)
  getGlobalDB pkgexe = do
    logDebug "Getting global package database location"
    -- This seems like a strange way to get the global package database
    -- location, but I don't know of a better one
    bs <- ghcPkg pkgexe [] ["list", "--global"] >>= either throwIO pure
    let fp = S8.unpack $ stripTrailingColon $ firstLine bs
    liftIO $ resolveDir' fp
   where
    stripTrailingColon bs
      | S8.null bs = bs
      | S8.last bs == ':' = S8.init bs
      | otherwise = bs
    firstLine = S8.takeWhile (\c -> c /= '\r' && c /= '\n')
  
  -- | Run the ghc-pkg executable
  ghcPkg ::
       (HasProcessContext env, HasTerm env)
    => GhcPkgExe
    -> [Path Abs Dir]
    -> [String]
    -> RIO env (Either SomeException S8.ByteString)
  ghcPkg pkgexe@(GhcPkgExe pkgPath) pkgDbs args = do
    eres <- go
    case eres of
      Left e -> do
        prettyDebug $
             fillSep
               [ flow "While using"
               , style Shell "ghc-pkg" <>","
               , flow "Stack encountered the following error:"
               ]
          <> blankLine
          <> string (displayException e)
          <> flow "Trying again after considering database creation..."
        mapM_ (createDatabase pkgexe) pkgDbs
        go
      Right _ -> pure eres
   where
    pkg = toFilePath pkgPath
    go = tryAny $ BL.toStrict . fst <$> proc pkg args' readProcess_
    args' = packageDbFlags pkgDbs ++ args
  
  -- | Create a package database in the given directory, if it doesn't exist.
  createDatabase ::
       (HasProcessContext env, HasTerm env)
    => GhcPkgExe
    -> Path Abs Dir
    -> RIO env ()
  createDatabase (GhcPkgExe pkgPath) db = do
    exists <- doesFileExist (db </> relFilePackageCache)
    unless exists $ do
      -- ghc-pkg requires that the database directory does not exist
      -- yet. If the directory exists but the package.cache file
      -- does, we're in a corrupted state. Check for that state.
      dirExists <- doesDirExist db
      args <- if dirExists
        then do
          prettyWarnL
            [ flow "The package database located at"
            , pretty db
            , flow "is corrupted. It is missing its"
            , style File "package.cache"
            , flow "file. Stack is proceeding with a recache."
            ]
          pure ["--package-db", toFilePath db, "recache"]
        else do
          -- Creating the parent doesn't seem necessary, as ghc-pkg
          -- seems to be sufficiently smart. But I don't feel like
          -- finding out it isn't the hard way
          ensureDir (parent db)
          pure ["init", toFilePath db]
      void $ proc (toFilePath pkgPath) args $ \pc ->
        onException (readProcess_ pc) $
          logError $
            "Error: [S-9735]\n" <>
             "Unable to create package database at " <>
             fromString (toFilePath db)
  
  -- | Get the environment variable to use for the package DB paths.
  ghcPkgPathEnvVar :: WhichCompiler -> Text
  ghcPkgPathEnvVar Ghc = "GHC_PACKAGE_PATH"
  
  -- | Get the necessary ghc-pkg flags for setting up the given package database
  packageDbFlags :: [Path Abs Dir] -> [String]
  packageDbFlags pkgDbs =
      "--no-user-package-db"
    : map (\x -> "--package-db=" ++ toFilePath x) pkgDbs
  
  -- | Get the value of a field of the package.
  findGhcPkgField ::
       (HasProcessContext env, HasTerm env)
    => GhcPkgExe
    -> [Path Abs Dir] -- ^ package databases
    -> String -- ^ package identifier, or GhcPkgId
    -> Text
    -> RIO env (Maybe Text)
  findGhcPkgField pkgexe pkgDbs name field =
    let cmd = ["field", "--simple-output", name, T.unpack field]
    in  ghcPkg pkgexe pkgDbs cmd <&> \case
          Left _ -> Nothing
          Right bs -> fmap (stripCR . T.decodeUtf8) $ listToMaybe $ S8.lines bs
  
  -- | unregister list of package ghcids, batching available from GHC 8.2.1,
  -- see https://github.com/commercialhaskell/stack/issues/2662#issuecomment-460342402
  -- using GHC package id where available (from GHC 7.9)
  --
  -- The version of the ghc-pkg executable supplied with GHCs published before
  -- 28 August 2023 does not efficiently bulk unregister. Until an \'efficient\'
  -- ghc-pkg is available, this function no longer uses:
  --
  -- >   eres <- ghcPkg pkgexe [pkgDb] args
  -- > where
  -- >    args = "unregister" : "--user" : "--force" :
  -- >      map packageIdentifierString idents ++
  -- >      if null gids then [] else "--ipid" : map ghcPkgIdString gids
  --
  -- but uses:
  --
  -- >   globalDb <- view $ compilerPathsL.to cpGlobalDB
  -- >   eres <- tryAny $ liftIO $
  -- >     ghcPkgUnregisterUserForce globalDb pkgDb hasIpid pkgarg_strs
  --
  unregisterGhcPkgIds ::
       (HasCompiler env, HasProcessContext env, HasTerm env)
    => Bool
       -- ^ Report pretty exceptions as warnings?
    -> GhcPkgExe
    -> Path Abs Dir -- ^ package database
    -> NonEmpty (Either PackageIdentifier GhcPkgId)
    -> RIO env ()
  unregisterGhcPkgIds isWarn pkgexe pkgDb epgids = do
    globalDb <- view $ compilerPathsL . to (.globalDB)
    try (ghcPkgUnregisterForce globalDb pkgDb hasIpid pkgarg_strs) >>= \case
      Left (PrettyException e) -> when isWarn $
        prettyWarn $
          "[S-8729]"
          <> line
          <> flow "While unregistering packages, Stack encountered the following \
                  \error:"
          <> blankLine
          <> pretty e
      Right _ -> pure ()
    -- ghcPkgUnregisterForce does not perform an effective 'ghc-pkg recache', as
    -- that depends on a specific version of the Cabal package.
    ghcPkg pkgexe [pkgDb] ["recache"] >>= \case
      Left err -> prettyThrowM $ CannotRecacheAfterUnregister pkgDb err
      Right _ -> pure ()
   where
    (idents, gids) = partitionEithers $ toList epgids
    hasIpid = not (null gids)
    pkgarg_strs = map packageIdentifierString idents <> map ghcPkgIdString gids
  
  -- | Get the value for GHC_PACKAGE_PATH
  mkGhcPackagePath :: Bool -> Path Abs Dir -> Path Abs Dir -> [Path Abs Dir] -> Path Abs Dir -> Text
  mkGhcPackagePath locals localdb deps extras globaldb =
    T.pack $ L.intercalate [searchPathSeparator] $ concat
      [ [toFilePathNoTrailingSep localdb | locals]
      , [toFilePathNoTrailingSep deps]
      , [toFilePathNoTrailingSep db | db <- reverse extras]
      , [toFilePathNoTrailingSep globaldb]
      ]
  