direct ghc package-db flags

shayne-fletcher · Jul 22, 2024 · 6d3f9c8 · 6d3f9c8
1 parent e0b31d9
commit 6d3f9c8
Showing 1 changed file with 17 additions and 46 deletions.
diff --git a/ghc-lib-gen/src/Ghclibgen.hs b/ghc-lib-gen/src/Ghclibgen.hs
@@ -297,43 +297,23 @@ ghcNumericVersion = do
   let ghcInfoMap = Map.fromList ghcInfo
   pure $ fromJust $ Map.lookup "Project version" ghcInfoMap
 
-cygpath :: FilePath -> IO FilePath
-cygpath p = systemOutput_ $ "bash -c 'echo -n $(cygpath -u \"" ++ p ++ "\")'"
-
 cabalPackageDb :: String -> IO String
 cabalPackageDb ghcNumericVersion = do
-  cabalStoreDir <-
-    if not isWindows then
-      systemOutput_ "cabal path --store-dir"
-    else
-      cygpath . replace "\\" "\\\\" =<< systemOutput_ "cabal path --store-dir"
+  cabalStoreDir <- replace "\\" "\\\\" <$> systemOutput_ "cabal path --store-dir"
   ghcInfo <- getGhcInfo
   let ghcInfoMap = Map.fromList ghcInfo
   let ghcDir =
         case Map.lookup "Project Unit Id" ghcInfoMap of
           Just projectUnitId -> projectUnitId -- e.g. ghc-9.10.1-2e29
           Nothing -> "ghc-" ++ ghcNumericVersion
-  msg <- systemOutput_ $ "bash -c 'echo \"cabal store contents: \" && ls " ++ cabalStoreDir ++ "'"
-  putStrLn msg
   pure $ cabalStoreDir ++ "/" ++ ghcDir ++ "/package.db"
 
 ghcPackageDb :: String -> IO String
 ghcPackageDb _ghcNumericVersion = do
   ghcInfo <- getGhcInfo
   let ghcInfoMap = Map.fromList ghcInfo
-  let packageDb = replace "\\" "\\\\" $ fromJust $ Map.lookup  "Global Package DB" ghcInfoMap
-  if not isWindows then
-    pure packageDb
-  else
-    cygpath packageDb
-
-ghcPackagePath :: String -> String -> String -> IO String
-ghcPackagePath ghcPackageDb cabalPackageDb ghcNumericVersion =
-  pure $ "GHC_PACKAGE_PATH=" ++ cabalPackageDb ++ ":" ++ ghcPackageDb
-
-semaphoreCompatBootExists :: IO Bool
-semaphoreCompatBootExists =
-  (== ExitSuccess) . fst <$> systemOutput "bash -c \"ghc-pkg list | grep semaphore-compat\""
+      packageDb = replace "\\" "\\\\" $ fromJust $ Map.lookup  "Global Package DB" ghcInfoMap
+  pure packageDb
 
 setupModuleDepsPlaceholders :: GhcFlavor -> IO ()
 setupModuleDepsPlaceholders _ = do
@@ -358,18 +338,12 @@ setupModuleDepsPlaceholders _ = do
               createDirectoryIfMissing True dir
               copyFile file new_p
 
-calcModuleDeps :: [FilePath] -> [FilePath] -> [FilePath] -> GhcFlavor -> String -> String -> String
-calcModuleDeps includeDirs _hsSrcDirs hsSrcIncludes ghcFlavor ghcPackagePath ghcMakeModeOutputFile =
-  let cmd = unwords $
-        [ "ghc", "-M"
-        , "-dep-suffix ''"
-        , "-dep-makefile " ++ ghcMakeModeOutputFile
-        ]  ++
-        [ "-optP -DGHCI" | series < GHC_8_10 ] ++
-        [ "-package semaphore-compat" | series >= GHC_9_8 ] ++
-        includeDirs ++ hsSrcIncludes ++ [ placeholderModulesDir </> "Main.hs" ]
-      cmd' = "bash -c \"" ++ ghcPackagePath ++ " " ++ cmd ++ "\""
-  in cmd'
+calcModuleDeps :: [FilePath] -> [FilePath] -> [FilePath] -> GhcFlavor -> FilePath -> FilePath -> String -> String
+calcModuleDeps includeDirs _hsSrcDirs hsSrcIncludes ghcFlavor _ghcPackageDb cabalPackageDb ghcMakeModeOutputFile = unwords $
+  [ "ghc -M -dep-suffix '' -dep-makefile " ++ ghcMakeModeOutputFile]  ++
+  [ "-clear-package-db -global-package-db -user-package-db -package-db " ++ cabalPackageDb ] ++ [ "-package semaphore-compat" | series >= GHC_9_8 ] ++
+  [ "-optP -DGHCI" | series < GHC_8_10 ] ++
+  includeDirs ++ hsSrcIncludes ++ [ placeholderModulesDir </> "Main.hs" ]
   where
     series = ghcSeries ghcFlavor
 
@@ -396,25 +370,20 @@ readGhcMakeModeOutputFile file hsSrcDirs = do
 
   return $ nubSort modules
 
-ghcPackagePath' :: IO String
-ghcPackagePath' = do
-  ghcNumericVersion <- ghcNumericVersion
-  ghcPackageDb <- ghcPackageDb ghcNumericVersion
-  cabalPackageDb <- cabalPackageDb ghcNumericVersion
-  ghcPackagePath ghcPackageDb cabalPackageDb ghcNumericVersion
-
 calcParserModules :: GhcFlavor -> IO [String]
 calcParserModules ghcFlavor = do
   let rootModulePath = placeholderModulesDir </> "Main.hs"
       series = ghcSeries ghcFlavor
       mainFile = "../ghc-lib-gen/ghc-lib-parser" </> show series </> "Main.hs"
   copyFile mainFile rootModulePath
   lib <- mapM readCabalFile (cabalFileLibraries ghcFlavor)
-  ghcPackagePath <- ghcPackagePath'
+  ghcNumericVersion <- ghcNumericVersion
+  ghcPackageDb <- ghcPackageDb ghcNumericVersion
+  cabalPackageDb <- cabalPackageDb ghcNumericVersion
   let includeDirs = map ("-I" ++ ) (ghcLibParserIncludeDirs ghcFlavor)
       hsSrcDirs = placeholderModulesDir : ghcLibParserHsSrcDirs True ghcFlavor lib
       hsSrcIncludes = map ("-i" ++ ) hsSrcDirs
-      cmd' = calcModuleDeps includeDirs hsSrcDirs hsSrcIncludes ghcFlavor ghcPackagePath ".parser-depends"
+      cmd' = calcModuleDeps includeDirs hsSrcDirs hsSrcIncludes ghcFlavor ghcPackageDb cabalPackageDb ".parser-depends"
   putStrLn "# Generating 'ghc/.parser-depends'..."
   putStrLn $ "\n\n# Running: " ++ cmd'
   system_ cmd'
@@ -427,11 +396,13 @@ calcLibModules ghcFlavor = do
       mainFile = "../ghc-lib-gen/ghc-lib" </> show series </> "Main.hs"
   copyFile mainFile rootModulePath
   lib <- mapM readCabalFile (cabalFileLibraries ghcFlavor)
-  ghcPackagePath <- ghcPackagePath'
+  ghcNumericVersion <- ghcNumericVersion
+  ghcPackageDb <- ghcPackageDb ghcNumericVersion
+  cabalPackageDb <- cabalPackageDb ghcNumericVersion
   let includeDirs = map ("-I" ++ ) (ghcLibIncludeDirs ghcFlavor)
       hsSrcDirs = placeholderModulesDir : ghcLibHsSrcDirs True ghcFlavor lib
       hsSrcIncludes = map ("-i" ++ ) hsSrcDirs
-      cmd' = calcModuleDeps includeDirs hsSrcDirs hsSrcIncludes ghcFlavor ghcPackagePath ".lib-depends"
+      cmd' = calcModuleDeps includeDirs hsSrcDirs hsSrcIncludes ghcFlavor ghcPackageDb cabalPackageDb ".lib-depends"
   putStrLn "# Generating 'ghc/.lib-depends'..."
   putStrLn $ "\n\n# Running: " ++ cmd'
   system_ cmd'