Improve migration strategy for the XDG compliance change to the GHC application

directory.

We want to always use the old path (~/.ghc/..) if it exists.
But we never want to create the old path.
This ensures that the migration can eventually be completed once older GHC
versions are no longer in circulation.

Fixes #20684, #20669, #20660

4 files changed, 111 insertions, 59 deletions

diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 2e7574837f..b17b0c8d3d 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE LambdaCase #-}
 
 -------------------------------------------------------------------------------
 --
@@ -887,13 +888,28 @@ opt_i                 :: DynFlags -> [String]
 opt_i dflags= toolSettings_opt_i $ toolSettings dflags
 
 -- | The directory for this version of ghc in the user's app directory
--- (typically something like @~/.ghc/x86_64-linux-7.6.3@)
+-- The appdir used to be in ~/.ghc but to respect the XDG specification
+-- we want to move it under $XDG_DATA_HOME/
+-- However, old tooling (like cabal) might still write package environments
+-- to the old directory, so we prefer that if a subdirectory of ~/.ghc
+-- with the correct target and GHC version suffix exists.
 --
+-- i.e. if ~/.ghc/$UNIQUE_SUBDIR exists we use that
+-- otherwise we use $XDG_DATA_HOME/$UNIQUE_SUBDIR
+--
+-- UNIQUE_SUBDIR is typically a combination of the target platform and GHC version
 versionedAppDir :: String -> ArchOS -> MaybeT IO FilePath
 versionedAppDir appname platform = do
   -- Make sure we handle the case the HOME isn't set (see #11678)
-  appdir <- tryMaybeT $ getXdgDirectory XdgData appname
-  return $ appdir </> versionedFilePath platform
+  -- We need to fallback to the old scheme if the subdirectory exists.
+  msum $ map (checkIfExists <=< fmap (</> versionedFilePath platform))
+       [ tryMaybeT $ getAppUserDataDirectory appname  -- this is ~/.ghc/
+       , tryMaybeT $ getXdgDirectory XdgData appname -- this is $XDG_DATA_HOME/
+       ]
+  where
+    checkIfExists dir = tryMaybeT (doesDirectoryExist dir) >>= \case
+      True -> pure dir
+      False -> MaybeT (pure Nothing)
 
 versionedFilePath :: ArchOS -> FilePath
 versionedFilePath platform = uniqueSubdir platform
diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst
index 8140a367aa..75e7268cc1 100644
--- a/docs/users_guide/9.4.1-notes.rst
+++ b/docs/users_guide/9.4.1-notes.rst
@@ -67,6 +67,25 @@ Compiler
 
 - Support for Sun SPARC architecture has been dropped (:ghc-ticket:`16883`).
 
+- A fix for GHC's handling of the XDG Base Directory Specification
+  (:ghc-ticket:`6077`, :ghc-ticket:`20684`, :ghc-ticket:`20669`,
+  :ghc-ticket:`20660`):
+
+  - For the package database previously in `~/.ghc/<arch-ver>`, we
+    will continue to use the old path if it exists. For example, if the
+    `~/.ghc/x86_64-linux-9.4.1` directory exists, GHC will use that for its
+    user package database. If this directory does not exist, we will use
+    `$XDG_DATA_HOME/ghc/x86_64-linux-9.4.1`. This is in order to give tooling like
+    cabal time to migrate
+
+  - For GHCi configuration files previously located in `~/.ghc/` like
+    `ghci.conf` and `ghci_history`, we will first check if they exist in
+    `~/.ghc` and use those if they do. However, we will create new files like
+    `ghci_history` only in `$XDG_DATA_HOME/ghc`. So if you don't have a previous
+    GHC installation which created `~/.ghc/ghci_history`, the history file will be
+    written to `$XDG_DATA_HOME/ghc`. If you already have an older GHC installation which
+    wrote `~/.ghc/ghci_history`, then GHC will continue to write the history to that file.
+
 ``base`` library
 ~~~~~~~~~~~~~~~~
 
diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index cf58baa0a6..5f1e4a2147 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -619,28 +619,30 @@ ghciLogAction lastErrLocations old_log_action
             _ -> return ()
         _ -> return ()
 
-withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
-withGhcAppData right left = do
-    either_dir <- tryIO (getXdgDirectory XdgData "ghc")
-    case either_dir of
-        Right dir ->
-            do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
-               right dir
-        _ -> left
-
-withGhcConfig :: (FilePath -> IO a) -> IO a -> IO a
-withGhcConfig right left = do
-    old_path <- getAppUserDataDirectory "ghc"
-    use_old_path <- doesPathExist old_path
-    let path = (if use_old_path
-                 then getAppUserDataDirectory "ghc"
-                 else getXdgDirectory XdgConfig "ghc")
-    either_dir <- tryIO (path)
-    case either_dir of
-        Right dir ->
-            do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
-               right dir
-        _ -> left
+-- | Takes a file name and prefixes it with the appropriate
+-- GHC appdir.
+-- Uses ~/.ghc (getAppUserDataDirectory) if it exists
+-- If it doesn't, then it uses $XDG_DATA_HOME/ghc
+-- Earlier we always used to use ~/.ghc, but we want
+-- to gradually move to $XDG_DATA_HOME to respect the XDG specification
+--
+-- As a migration strategy, we will only create new directories in
+-- the appropriate XDG location. However, we will use the old directory
+-- if it already exists.
+getAppDataFile :: FilePath -> IO (Maybe FilePath)
+getAppDataFile file = do
+    let new_path = tryIO (getXdgDirectory XdgConfig "ghc") >>= \case
+          Left _ -> pure Nothing
+          Right dir -> flip catchIO (const $ return Nothing) $ do
+            createDirectoryIfMissing False dir
+            pure $ Just $ dir </> file
+
+    e_old_path <- tryIO (getAppUserDataDirectory "ghc")
+    case e_old_path of
+      Right old_path -> doesDirectoryExist old_path >>= \case
+        True -> pure $ Just $ old_path </> file
+        False -> new_path
+      Left _ -> new_path
 
 runGHCi :: [(FilePath, Maybe UnitId, Maybe Phase)] -> Maybe [String] -> GHCi ()
 runGHCi paths maybe_exprs = do
@@ -648,9 +650,7 @@ runGHCi paths maybe_exprs = do
   let
    ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags
 
-   app_user_dir = liftIO $ withGhcConfig
-                    (\dir -> return (Just (dir </> "ghci.conf")))
-                    (return Nothing)
+   app_user_dir = liftIO $ getAppDataFile "ghci.conf"
 
    home_dir = do
     either_dir <- liftIO $ tryIO (getEnv "HOME")
@@ -781,8 +781,7 @@ runGHCiInput f = do
 
     histFile <- case (ghciHistory, localGhciHistory) of
       (True, True) -> return (Just (currentDirectory </> ".ghci_history"))
-      (True, _) -> liftIO $ withGhcAppData
-        (\dir -> return (Just (dir </> "ghci_history"))) (return Nothing)
+      (True, _) -> liftIO $ getAppDataFile "ghci_history"
       _ -> return Nothing
 
     runInputT
diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 4df73001d5..bb6ee4d9fa 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -58,7 +58,7 @@ import Distribution.Simple.Utils (toUTF8BS, writeUTF8File, readUTF8File)
 import qualified Data.Version as Version
 import System.FilePath as FilePath
 import qualified System.FilePath.Posix as FilePath.Posix
-import System.Directory ( getXdgDirectory, createDirectoryIfMissing,
+import System.Directory ( getXdgDirectory, createDirectoryIfMissing, getAppUserDataDirectory,
                           getModificationTime, XdgDirectory ( XdgData ) )
 import Text.Printf
 
@@ -636,38 +636,56 @@ getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
 
   -- get the location of the user package database, and create it if necessary
   -- getXdgDirectory can fail (e.g. if $HOME isn't set)
-  e_appdir <- tryIO $ getXdgDirectory XdgData "ghc"
 
   mb_user_conf <-
     case [ f | FlagUserConfig f <- my_flags ] of
       _ | no_user_db -> return Nothing
-      [] -> case e_appdir of
-        Left _    -> return Nothing
-        Right appdir -> do
-          -- See Note [Settings File] about this file, and why we need GHC to share it with us.
-          let settingsFile = top_dir </> "settings"
-          exists_settings_file <- doesFileExist settingsFile
-          targetArchOS <- case exists_settings_file of
-            False -> do
-              warn $ "WARNING: settings file doesn't exist " ++ show settingsFile
-              warn "cannot know target platform so guessing target == host (native compiler)."
-              pure hostPlatformArchOS
-            True -> do
-              settingsStr <- readFile settingsFile
-              mySettings <- case maybeReadFuzzy settingsStr of
-                Just s -> pure $ Map.fromList s
-                -- It's excusable to not have a settings file (for now at
-                -- least) but completely inexcusable to have a malformed one.
-                Nothing -> die $ "Can't parse settings file " ++ show settingsFile
-              case getTargetArchOS settingsFile mySettings of
-                Right archOS -> pure archOS
-                Left e -> die e
-          let subdir = uniqueSubdir targetArchOS
-              dir = appdir </> subdir
-          r <- lookForPackageDBIn dir
-          case r of
-            Nothing -> return (Just (dir </> "package.conf.d", False))
-            Just f  -> return (Just (f, True))
+      [] -> do
+        -- See Note [Settings File] about this file, and why we need GHC to share it with us.
+        let settingsFile = top_dir </> "settings"
+        exists_settings_file <- doesFileExist settingsFile
+        targetArchOS <- case exists_settings_file of
+          False -> do
+            warn $ "WARNING: settings file doesn't exist " ++ show settingsFile
+            warn "cannot know target platform so guessing target == host (native compiler)."
+            pure hostPlatformArchOS
+          True -> do
+            settingsStr <- readFile settingsFile
+            mySettings <- case maybeReadFuzzy settingsStr of
+              Just s -> pure $ Map.fromList s
+              -- It's excusable to not have a settings file (for now at
+              -- least) but completely inexcusable to have a malformed one.
+              Nothing -> die $ "Can't parse settings file " ++ show settingsFile
+            case getTargetArchOS settingsFile mySettings of
+              Right archOS -> pure archOS
+              Left e -> die e
+        let subdir = uniqueSubdir targetArchOS
+
+            getFirstSuccess :: [IO a] -> IO (Maybe a)
+            getFirstSuccess [] = pure Nothing
+            getFirstSuccess (a:as) = tryIO a >>= \case
+              Left _ -> getFirstSuccess as
+              Right d -> pure (Just d)
+        -- The appdir used to be in ~/.ghc but to respect the XDG specification
+        -- we want to move it under $XDG_DATA_HOME/
+        -- However, old tooling (like cabal) might still write package environments
+        -- to the old directory, so we prefer that if a subdirectory of ~/.ghc
+        -- with the correct target and GHC version exists.
+        --
+        -- i.e. if ~/.ghc/$UNIQUE_SUBDIR exists we prefer that
+        -- otherwise we use $XDG_DATA_HOME/$UNIQUE_SUBDIR
+        --
+        -- UNIQUE_SUBDIR is typically a combination of the target platform and GHC version
+        m_appdir <- getFirstSuccess $ map (fmap (</> subdir))
+          [ getAppUserDataDirectory "ghc"  -- this is ~/.ghc/
+          , getXdgDirectory XdgData "ghc"  -- this is $XDG_DATA_HOME/
+          ]
+        case m_appdir of
+          Nothing -> return Nothing
+          Just dir -> do
+            lookForPackageDBIn dir >>= \case
+              Nothing -> return (Just (dir </> "package.conf.d", False))
+              Just f  -> return (Just (f, True))
       fs -> return (Just (last fs, True))
 
   -- If the user database exists, and for "use_user" commands (which includes