From c8ece0df3316b9f1934f3f059437bc055f5cfae2 Mon Sep 17 00:00:00 2001
From: Fendor <fendor@posteo.de>
Date: Fri, 1 Mar 2024 09:34:54 +0100
Subject: [PATCH] Migrate `Finder` component to `OsPath`, fixed #24616
For each module in a GHCi session, we keep alive one `ModLocation`.
A `ModLocation` is fairly inefficiently packed, as `String`s are
expensive in memory usage.
While benchmarking the agda codebase, we concluded that we keep alive
around 11MB of `FilePath`'s, solely retained by `ModLocation`.
We provide a more densely packed encoding of `ModLocation`, by moving
from `FilePath` to `OsPath`. Further, we migrate the full `Finder`
component to `OsPath` to avoid unnecessary transformations.
As the `Finder` component is well-encapsulated, this requires only a
minimal amount of changes in other modules.
We introduce pattern synonym for 'ModLocation' which maintains backwards
compatibility and avoids breaking consumers of 'ModLocation'.
---
compiler/GHC.hs | 2 +
compiler/GHC/Data/OsPath.hs | 29 ++++
compiler/GHC/Data/Strict.hs | 7 +-
compiler/GHC/Driver/Backpack.hs | 11 +-
compiler/GHC/Driver/CodeOutput.hs | 3 +-
compiler/GHC/Driver/Config/Finder.hs | 24 +--
compiler/GHC/Driver/Main.hs | 40 +++--
compiler/GHC/Driver/Make.hs | 17 +-
compiler/GHC/Driver/MakeFile.hs | 5 +-
compiler/GHC/Driver/Pipeline/Execute.hs | 13 +-
compiler/GHC/Iface/Errors.hs | 5 +-
compiler/GHC/Unit/Finder.hs | 155 +++++++++---------
compiler/GHC/Unit/Finder/Types.hs | 25 +--
compiler/GHC/Unit/Module/Location.hs | 101 ++++++++----
compiler/GHC/Unit/Module/ModSummary.hs | 13 ++
compiler/ghc.cabal.in | 4 +-
ghc/ghc-bin.cabal.in | 2 +-
.../tests/count-deps/CountDepsAst.stdout | 1 +
.../tests/count-deps/CountDepsParser.stdout | 1 +
.../src/Haddock/Interface/Create.hs | 7 +-
20 files changed, 286 insertions(+), 179 deletions(-)
create mode 100644 compiler/GHC/Data/OsPath.hs
diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 9473b477f684..8be3a7fa6040 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables #-}
{-# LANGUAGE TupleSections, NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PatternSynonyms #-}
-- -----------------------------------------------------------------------------
--
@@ -76,6 +77,7 @@ module GHC (
ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,
mgLookupModule,
ModSummary(..), ms_mod_name, ModLocation(..),
+ pattern ModLocation,
getModSummary,
getModuleGraph,
isLoaded,
diff --git a/compiler/GHC/Data/OsPath.hs b/compiler/GHC/Data/OsPath.hs
new file mode 100644
index 000000000000..12fcbd5f3a7e
--- /dev/null
+++ b/compiler/GHC/Data/OsPath.hs
@@ -0,0 +1,29 @@
+module GHC.Data.OsPath
+ (
+ -- * OsPath initialisation and transformation
+ OsPath
+ , OsString
+ , encodeUtf
+ , decodeUtf
+ , unsafeDecodeUtf
+ , unsafeEncodeUtf
+ , os
+ -- * Common utility functions
+ , (</>)
+ , (<.>)
+ )
+ where
+
+import GHC.Prelude
+
+import GHC.Utils.Misc (HasCallStack)
+import GHC.Utils.Panic (panic)
+
+import System.OsPath
+import System.Directory.Internal (os)
+
+-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed.
+-- Prefer 'decodeUtf' and gracious error handling.
+unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath
+unsafeDecodeUtf p =
+ either (\err -> panic $ "Failed to decodeUtf \"" ++ show p ++ "\", because: " ++ show err) id (decodeUtf p)
diff --git a/compiler/GHC/Data/Strict.hs b/compiler/GHC/Data/Strict.hs
index d028d51c6461..14928231008e 100644
--- a/compiler/GHC/Data/Strict.hs
+++ b/compiler/GHC/Data/Strict.hs
@@ -9,8 +9,8 @@
module GHC.Data.Strict (
Maybe(Nothing, Just),
fromMaybe,
+ GHC.Data.Strict.maybe,
Pair(And),
-
-- Not used at the moment:
--
-- Either(Left, Right),
@@ -18,6 +18,7 @@ module GHC.Data.Strict (
) where
import GHC.Prelude hiding (Maybe(..), Either(..))
+
import Control.Applicative
import Data.Semigroup
import Data.Data
@@ -29,6 +30,10 @@ fromMaybe :: a -> Maybe a -> a
fromMaybe d Nothing = d
fromMaybe _ (Just x) = x
+maybe :: b -> (a -> b) -> Maybe a -> b
+maybe d _ Nothing = d
+maybe _ f (Just x) = f x
+
apMaybe :: Maybe (a -> b) -> Maybe a -> Maybe b
apMaybe (Just f) (Just x) = Just (f x)
apMaybe _ _ = Nothing
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index ee9a70271c4a..f8d98c31d21f 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -74,6 +74,7 @@ import GHC.Linker.Types
import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.Maybe
+import GHC.Data.OsPath (unsafeEncodeUtf, os)
import GHC.Data.StringBuffer
import GHC.Data.FastString
import qualified GHC.Data.EnumSet as EnumSet
@@ -772,7 +773,7 @@ summariseRequirement pn mod_name = do
let PackageName pn_fs = pn
let location = mkHomeModLocation2 fopts mod_name
- (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"
+ (unsafeEncodeUtf $ unpackFS pn_fs </> moduleNameSlashes mod_name) (os "hsig")
env <- getBkpEnv
src_hash <- liftIO $ getFileHash (bkp_filename env)
@@ -855,12 +856,12 @@ hsModuleToModSummary home_keys pn hsc_src modname
-- these filenames to figure out where the hi files go.
-- A travesty!
let location0 = mkHomeModLocation2 fopts modname
- (unpackFS unit_fs </>
+ (unsafeEncodeUtf $ unpackFS unit_fs </>
moduleNameSlashes modname)
(case hsc_src of
- HsigFile -> "hsig"
- HsBootFile -> "hs-boot"
- HsSrcFile -> "hs")
+ HsigFile -> os "hsig"
+ HsBootFile -> os "hs-boot"
+ HsSrcFile -> os "hs")
-- DANGEROUS: bootifying can POISON the module finder cache
let location = case hsc_src of
HsBootFile -> addBootSuffixLocnOut location0
diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs
index 8da357d7c478..a2b542d3f3b5 100644
--- a/compiler/GHC/Driver/CodeOutput.hs
+++ b/compiler/GHC/Driver/CodeOutput.hs
@@ -35,6 +35,7 @@ import GHC.Driver.LlvmConfigCache (LlvmConfigCache)
import GHC.Driver.Ppr
import GHC.Driver.Backend
+import GHC.Data.OsPath
import qualified GHC.Data.ShortText as ST
import GHC.Data.Stream ( Stream )
import qualified GHC.Data.Stream as Stream
@@ -259,7 +260,7 @@ outputForeignStubs
Maybe FilePath) -- C file created
outputForeignStubs logger tmpfs dflags unit_state mod location stubs
= do
- let stub_h = mkStubPaths (initFinderOpts dflags) (moduleName mod) location
+ let stub_h = unsafeDecodeUtf $ mkStubPaths (initFinderOpts dflags) (moduleName mod) location
stub_c <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"
case stubs of
diff --git a/compiler/GHC/Driver/Config/Finder.hs b/compiler/GHC/Driver/Config/Finder.hs
index 5b73db5ca253..4371813ebb92 100644
--- a/compiler/GHC/Driver/Config/Finder.hs
+++ b/compiler/GHC/Driver/Config/Finder.hs
@@ -8,27 +8,27 @@ import GHC.Prelude
import GHC.Driver.DynFlags
import GHC.Unit.Finder.Types
import GHC.Data.FastString
-
+import GHC.Data.OsPath
-- | Create a new 'FinderOpts' from DynFlags.
initFinderOpts :: DynFlags -> FinderOpts
initFinderOpts flags = FinderOpts
- { finder_importPaths = importPaths flags
+ { finder_importPaths = fmap unsafeEncodeUtf $ importPaths flags
, finder_lookupHomeInterfaces = isOneShot (ghcMode flags)
, finder_bypassHiFileCheck = MkDepend == (ghcMode flags)
, finder_ways = ways flags
, finder_enableSuggestions = gopt Opt_HelpfulErrors flags
- , finder_workingDirectory = workingDirectory flags
+ , finder_workingDirectory = fmap unsafeEncodeUtf $ workingDirectory flags
, finder_thisPackageName = mkFastString <$> thisPackageName flags
, finder_hiddenModules = hiddenModules flags
, finder_reexportedModules = reexportedModules flags
- , finder_hieDir = hieDir flags
- , finder_hieSuf = hieSuf flags
- , finder_hiDir = hiDir flags
- , finder_hiSuf = hiSuf_ flags
- , finder_dynHiSuf = dynHiSuf_ flags
- , finder_objectDir = objectDir flags
- , finder_objectSuf = objectSuf_ flags
- , finder_dynObjectSuf = dynObjectSuf_ flags
- , finder_stubDir = stubDir flags
+ , finder_hieDir = fmap unsafeEncodeUtf $ hieDir flags
+ , finder_hieSuf = unsafeEncodeUtf $ hieSuf flags
+ , finder_hiDir = fmap unsafeEncodeUtf $ hiDir flags
+ , finder_hiSuf = unsafeEncodeUtf $ hiSuf_ flags
+ , finder_dynHiSuf = unsafeEncodeUtf $ dynHiSuf_ flags
+ , finder_objectDir = fmap unsafeEncodeUtf $ objectDir flags
+ , finder_objectSuf = unsafeEncodeUtf $ objectSuf_ flags
+ , finder_dynObjectSuf = unsafeEncodeUtf $ dynObjectSuf_ flags
+ , finder_stubDir = fmap unsafeEncodeUtf $ stubDir flags
}
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 72c8a6faf193..003651bffa8d 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -264,6 +264,7 @@ import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.FastString
import GHC.Data.Bag
+import GHC.Data.OsPath (unsafeEncodeUtf)
import GHC.Data.StringBuffer
import qualified GHC.Data.Stream as Stream
import GHC.Data.Stream (Stream)
@@ -2111,12 +2112,13 @@ hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hs
rawCmms
return stub_c_exists
where
- no_loc = ModLocation{ ml_hs_file = Just original_filename,
- ml_hi_file = panic "hscCompileCmmFile: no hi file",
- ml_obj_file = panic "hscCompileCmmFile: no obj file",
- ml_dyn_obj_file = panic "hscCompileCmmFile: no dyn obj file",
- ml_dyn_hi_file = panic "hscCompileCmmFile: no dyn obj file",
- ml_hie_file = panic "hscCompileCmmFile: no hie file"}
+ no_loc = OsPathModLocation
+ { ml_hs_file_ospath = Just $ unsafeEncodeUtf original_filename,
+ ml_hi_file_ospath = panic "hscCompileCmmFile: no hi file",
+ ml_obj_file_ospath = panic "hscCompileCmmFile: no obj file",
+ ml_dyn_obj_file_ospath = panic "hscCompileCmmFile: no dyn obj file",
+ ml_dyn_hi_file_ospath = panic "hscCompileCmmFile: no dyn obj file",
+ ml_hie_file_ospath = panic "hscCompileCmmFile: no hie file"}
-------------------- Stuff for new code gen ---------------------
@@ -2351,12 +2353,13 @@ hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
{- Desugar it -}
-- We use a basically null location for iNTERACTIVE
- let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
- ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file",
- ml_obj_file = panic "hsDeclsWithLocation:ml_obj_file",
- ml_dyn_obj_file = panic "hsDeclsWithLocation:ml_dyn_obj_file",
- ml_dyn_hi_file = panic "hsDeclsWithLocation:ml_dyn_hi_file",
- ml_hie_file = panic "hsDeclsWithLocation:ml_hie_file" }
+ let iNTERACTIVELoc = OsPathModLocation
+ { ml_hs_file_ospath = Nothing,
+ ml_hi_file_ospath = panic "hsDeclsWithLocation:ml_hi_file_ospath",
+ ml_obj_file_ospath = panic "hsDeclsWithLocation:ml_obj_file_ospath",
+ ml_dyn_obj_file_ospath = panic "hsDeclsWithLocation:ml_dyn_obj_file_ospath",
+ ml_dyn_hi_file_ospath = panic "hsDeclsWithLocation:ml_dyn_hi_file_ospath",
+ ml_hie_file_ospath = panic "hsDeclsWithLocation:ml_hie_file_ospath" }
ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
{- Simplify -}
@@ -2635,12 +2638,13 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr = do
{- Lint if necessary -}
lintInteractiveExpr (text "hscCompileCoreExpr") hsc_env prepd_expr
- let this_loc = ModLocation{ ml_hs_file = Nothing,
- ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file",
- ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file",
- ml_dyn_obj_file = panic "hscCompileCoreExpr': ml_obj_file",
- ml_dyn_hi_file = panic "hscCompileCoreExpr': ml_dyn_hi_file",
- ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" }
+ let this_loc = OsPathModLocation
+ { ml_hs_file_ospath = Nothing,
+ ml_hi_file_ospath = panic "hscCompileCoreExpr':ml_hi_file_ospath",
+ ml_obj_file_ospath = panic "hscCompileCoreExpr':ml_obj_file_ospath",
+ ml_dyn_obj_file_ospath = panic "hscCompileCoreExpr': ml_obj_file_ospath",
+ ml_dyn_hi_file_ospath = panic "hscCompileCoreExpr': ml_dyn_hi_file_ospath",
+ ml_hie_file_ospath = panic "hscCompileCoreExpr':ml_hie_file_ospath" }
-- Ensure module uniqueness by giving it a name like "GhciNNNN".
-- This uniqueness is needed by the JS linker. Without it we break the 1-1
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 509bfc7395af..2eea6442b3e2 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -76,6 +76,7 @@ import GHC.Data.Bag ( listToBag )
import GHC.Data.Graph.Directed
import GHC.Data.FastString
import GHC.Data.Maybe ( expectJust )
+import GHC.Data.OsPath ( unsafeEncodeUtf )
import GHC.Data.StringBuffer
import qualified GHC.LanguageExtensions as LangExt
@@ -1837,7 +1838,7 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf
let dyn_tn = tn -<.> dynsuf
addFilesToClean tmpfs dynLife [dyn_tn]
- return (tn, dyn_tn)
+ return (unsafeEncodeUtf tn, unsafeEncodeUtf dyn_tn)
-- We don't want to create .o or .hi files unless we have been asked
-- to by the user. But we need them, so we patch their locations in
-- the ModSummary with temporary files.
@@ -1846,8 +1847,8 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
-- If ``-fwrite-interface` is specified, then the .o and .hi files
-- are written into `-odir` and `-hidir` respectively. #16670
if gopt Opt_WriteInterface dflags
- then return ((ml_hi_file ms_location, ml_dyn_hi_file ms_location)
- , (ml_obj_file ms_location, ml_dyn_obj_file ms_location))
+ then return ((ml_hi_file_ospath ms_location, ml_dyn_hi_file_ospath ms_location)
+ , (ml_obj_file_ospath ms_location, ml_dyn_obj_file_ospath ms_location))
else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))
<*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))
let new_dflags = case enable_spec of
@@ -1856,10 +1857,10 @@ enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =
EnableByteCodeAndObject -> (gopt_set dflags Opt_ByteCodeAndObjectCode) { backend = defaultBackendOf ms}
let ms' = ms
{ ms_location =
- ms_location { ml_hi_file = hi_file
- , ml_obj_file = o_file
- , ml_dyn_hi_file = dyn_hi_file
- , ml_dyn_obj_file = dyn_o_file }
+ ms_location { ml_hi_file_ospath = hi_file
+ , ml_obj_file_ospath = o_file
+ , ml_dyn_hi_file_ospath = dyn_hi_file
+ , ml_dyn_obj_file_ospath = dyn_o_file }
, ms_hspp_opts = updOptLevel 0 $ new_dflags
}
-- Recursive call to catch the other cases
@@ -2044,7 +2045,7 @@ summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf
let fopts = initFinderOpts (hsc_dflags hsc_env)
-- Make a ModLocation for this file
- let location = mkHomeModLocation fopts pi_mod_name src_fn
+ let location = mkHomeModLocation fopts pi_mod_name (unsafeEncodeUtf src_fn)
-- Tell the Finder cache where it is, so that subsequent calls
-- to findModule will find it, even if it's not on any search path
diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs
index 80a7ba6181ab..0cb2d6d7fbb7 100644
--- a/compiler/GHC/Driver/MakeFile.hs
+++ b/compiler/GHC/Driver/MakeFile.hs
@@ -24,6 +24,7 @@ import GHC.Driver.Env
import GHC.Driver.Errors.Types
import qualified GHC.SysTools as SysTools
import GHC.Data.Graph.Directed ( SCC(..) )
+import GHC.Data.OsPath (unsafeDecodeUtf)
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.SourceError
@@ -252,7 +253,7 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ node))
-- files if the module has a corresponding .hs-boot file (#14482)
; when (isBootSummary node == IsBoot) $ do
let hi_boot = msHiFilePath node
- let obj = removeBootSuffix (msObjFilePath node)
+ let obj = unsafeDecodeUtf $ removeBootSuffix (msObjFileOsPath node)
forM_ extra_suffixes $ \suff -> do
let way_obj = insertSuffixes obj [suff]
let way_hi_boot = insertSuffixes hi_boot [suff]
@@ -297,7 +298,7 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do
Found loc _
-- Home package: just depend on the .hi or hi-boot file
| isJust (ml_hs_file loc) || include_pkg_deps
- -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc)))
+ -> return (Just (unsafeDecodeUtf $ addBootSuffix_maybe is_boot (ml_hi_file_ospath loc)))
-- Not in this package: we don't need a dependency
| otherwise
diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs
index 64ff838aa23e..6a4a30af6478 100644
--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ b/compiler/GHC/Driver/Pipeline/Execute.hs
@@ -58,6 +58,7 @@ import GHC.Iface.Make
import GHC.Driver.Config.Parser
import GHC.Parser.Header
import GHC.Data.StringBuffer
+import GHC.Data.OsPath (unsafeEncodeUtf)
import GHC.Types.SourceError
import GHC.Unit.Finder
import Data.IORef
@@ -772,7 +773,7 @@ mkOneShotModLocation :: PipeEnv -> DynFlags -> HscSource -> ModuleName -> IO Mod
mkOneShotModLocation pipe_env dflags src_flavour mod_name = do
let PipeEnv{ src_basename=basename,
src_suffix=suff } = pipe_env
- let location1 = mkHomeModLocation2 fopts mod_name basename suff
+ let location1 = mkHomeModLocation2 fopts mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf suff)
-- Boot-ify it if necessary
let location2
@@ -784,11 +785,11 @@ mkOneShotModLocation pipe_env dflags src_flavour mod_name = do
-- This can't be done in mkHomeModuleLocation because
-- it only applies to the module being compiles
let ohi = outputHi dflags
- location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
+ location3 | Just fn <- ohi = location2{ ml_hi_file_ospath = unsafeEncodeUtf fn }
| otherwise = location2
let dynohi = dynOutputHi dflags
- location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file = fn }
+ location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file_ospath = unsafeEncodeUtf fn }
| otherwise = location3
-- Take -o into account if present
@@ -802,10 +803,10 @@ mkOneShotModLocation pipe_env dflags src_flavour mod_name = do
location5 | Just ofile <- expl_o_file
, let dyn_ofile = fromMaybe (ofile -<.> dynObjectSuf_ dflags) expl_dyn_o_file
, isNoLink (ghcLink dflags)
- = location4 { ml_obj_file = ofile
- , ml_dyn_obj_file = dyn_ofile }
+ = location4 { ml_obj_file_ospath = unsafeEncodeUtf ofile
+ , ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }
| Just dyn_ofile <- expl_dyn_o_file
- = location4 { ml_dyn_obj_file = dyn_ofile }
+ = location4 { ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }
| otherwise = location4
return location5
where
diff --git a/compiler/GHC/Iface/Errors.hs b/compiler/GHC/Iface/Errors.hs
index 220c1d62ec95..9546b501663c 100644
--- a/compiler/GHC/Iface/Errors.hs
+++ b/compiler/GHC/Iface/Errors.hs
@@ -14,6 +14,7 @@ import GHC.Utils.Panic.Plain
import GHC.Driver.DynFlags
import GHC.Driver.Env
import GHC.Data.Maybe
+import GHC.Data.OsPath
import GHC.Prelude
import GHC.Unit
import GHC.Unit.Env
@@ -55,13 +56,13 @@ cantFindInstalledErr unit_state mhome_unit profile mod_name find_result
InstalledNotFound files mb_pkg
| Just pkg <- mb_pkg
, notHomeUnitId mhome_unit pkg
- -> not_found_in_package pkg files
+ -> not_found_in_package pkg $ fmap unsafeDecodeUtf files
| null files
-> NotAModule
| otherwise
- -> CouldntFindInFiles files
+ -> CouldntFindInFiles $ fmap unsafeDecodeUtf files
_ -> panic "cantFindInstalledErr"
diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs
index c113e2592f92..83838993cff3 100644
--- a/compiler/GHC/Unit/Finder.hs
+++ b/compiler/GHC/Unit/Finder.hs
@@ -42,6 +42,9 @@ import GHC.Platform.Ways
import GHC.Builtin.Names ( gHC_PRIM )
+import GHC.Data.Maybe ( expectJust )
+import GHC.Data.OsPath
+
import GHC.Unit.Env
import GHC.Unit.Types
import GHC.Unit.Module
@@ -49,7 +52,6 @@ import GHC.Unit.Home
import GHC.Unit.State
import GHC.Unit.Finder.Types
-import GHC.Data.Maybe ( expectJust )
import qualified GHC.Data.ShortText as ST
import GHC.Utils.Misc
@@ -61,8 +63,7 @@ import GHC.Types.PkgQual
import GHC.Fingerprint
import Data.IORef
-import System.Directory
-import System.FilePath
+import System.Directory.OsPath
import Control.Monad
import Data.Time
import qualified Data.Map as M
@@ -70,9 +71,10 @@ import GHC.Driver.Env
( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) )
import GHC.Driver.Config.Finder
import qualified Data.Set as Set
+import qualified System.OsPath as OsPath
-type FileExt = String -- Filename extension
-type BaseName = String -- Basename of file
+type FileExt = OsString -- Filename extension
+type BaseName = OsPath -- Basename of file
-- -----------------------------------------------------------------------------
-- The Finder
@@ -286,7 +288,7 @@ findLookupResult fc fopts r = case r of
-- implicit locations from the instances
InstalledFound loc _ -> return (Found loc m)
InstalledNoPackage _ -> return (NoPackage (moduleUnit m))
- InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnit m)
+ InstalledNotFound fp _ -> return (NotFound{ fr_paths = fmap unsafeDecodeUtf fp, fr_pkg = Just (moduleUnit m)
, fr_pkgs_hidden = []
, fr_mods_hidden = []
, fr_unusables = []
@@ -357,7 +359,7 @@ findHomeModule fc fopts home_unit mod_name = do
InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name)
InstalledNoPackage _ -> NoPackage uid -- impossible
InstalledNotFound fps _ -> NotFound {
- fr_paths = fps,
+ fr_paths = fmap unsafeDecodeUtf fps,
fr_pkg = Just uid,
fr_mods_hidden = [],
fr_pkgs_hidden = [],
@@ -382,7 +384,7 @@ findHomePackageModule fc fopts home_unit mod_name = do
InstalledFound loc _ -> Found loc (mkModule uid mod_name)
InstalledNoPackage _ -> NoPackage uid -- impossible
InstalledNotFound fps _ -> NotFound {
- fr_paths = fps,
+ fr_paths = fmap unsafeDecodeUtf fps,
fr_pkg = Just uid,
fr_mods_hidden = [],
fr_pkgs_hidden = [],
@@ -418,17 +420,17 @@ findInstalledHomeModule fc fopts home_unit mod_name = do
hi_dir_path =
case finder_hiDir fopts of
Just hiDir -> case maybe_working_dir of
- Nothing -> [hiDir]
- Just fp -> [fp </> hiDir]
+ Nothing -> [hiDir]
+ Just fp -> [fp </> hiDir]
Nothing -> home_path
hisuf = finder_hiSuf fopts
mod = mkModule home_unit mod_name
source_exts =
- [ ("hs", mkHomeModLocationSearched fopts mod_name "hs")
- , ("lhs", mkHomeModLocationSearched fopts mod_name "lhs")
- , ("hsig", mkHomeModLocationSearched fopts mod_name "hsig")
- , ("lhsig", mkHomeModLocationSearched fopts mod_name "lhsig")
+ [ (os "hs", mkHomeModLocationSearched fopts mod_name $ os "hs")
+ , (os "lhs", mkHomeModLocationSearched fopts mod_name $ os "lhs")
+ , (os "hsig", mkHomeModLocationSearched fopts mod_name $ os "hsig")
+ , (os "lhsig", mkHomeModLocationSearched fopts mod_name $ os "lhsig")
]
-- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that
@@ -453,10 +455,11 @@ findInstalledHomeModule fc fopts home_unit mod_name = do
else searchPathExts search_dirs mod exts
-- | Prepend the working directory to the search path.
-augmentImports :: FilePath -> [FilePath] -> [FilePath]
+augmentImports :: OsPath -> [OsPath] -> [OsPath]
augmentImports _work_dir [] = []
-augmentImports work_dir (fp:fps) | isAbsolute fp = fp : augmentImports work_dir fps
- | otherwise = (work_dir </> fp) : augmentImports work_dir fps
+augmentImports work_dir (fp:fps)
+ | OsPath.isAbsolute fp = fp : augmentImports work_dir fps
+ | otherwise = (work_dir </> fp) : augmentImports work_dir fps
-- | Search for a module in external packages only.
findPackageModule :: FinderCache -> UnitState -> FinderOpts -> InstalledModule -> IO InstalledFindResult
@@ -488,14 +491,14 @@ findPackageModule_ fc fopts mod pkg_conf = do
tag = waysBuildTag (finder_ways fopts)
-- hi-suffix for packages depends on the build tag.
- package_hisuf | null tag = "hi"
- | otherwise = tag ++ "_hi"
+ package_hisuf | null tag = os "hi"
+ | otherwise = os (tag ++ "_hi")
- package_dynhisuf = waysBuildTag (addWay WayDyn (finder_ways fopts)) ++ "_hi"
+ package_dynhisuf = os $ waysBuildTag (addWay WayDyn (finder_ways fopts)) ++ "_hi"
mk_hi_loc = mkHiOnlyModLocation fopts package_hisuf package_dynhisuf
- import_dirs = map ST.unpack $ unitImportDirs pkg_conf
+ import_dirs = map (unsafeEncodeUtf . ST.unpack) $ unitImportDirs pkg_conf
-- we never look for a .hi-boot file in an external package;
-- .hi-boot files only make sense for the home package.
in
@@ -503,7 +506,7 @@ findPackageModule_ fc fopts mod pkg_conf = do
[one] | finder_bypassHiFileCheck fopts ->
-- there's only one place that this .hi file can be, so
-- don't bother looking for it.
- let basename = moduleNameSlashes (moduleName mod)
+ let basename = unsafeEncodeUtf $ moduleNameSlashes (moduleName mod)
loc = mk_hi_loc one basename
in return $ InstalledFound loc mod
_otherwise ->
@@ -512,24 +515,24 @@ findPackageModule_ fc fopts mod pkg_conf = do
-- -----------------------------------------------------------------------------
-- General path searching
-searchPathExts :: [FilePath] -- paths to search
+searchPathExts :: [OsPath] -- paths to search
-> InstalledModule -- module name
-> [ (
- FileExt, -- suffix
- FilePath -> BaseName -> ModLocation -- action
+ FileExt, -- suffix
+ OsPath -> BaseName -> ModLocation -- action
)
]
-> IO InstalledFindResult
searchPathExts paths mod exts = search to_search
where
- basename = moduleNameSlashes (moduleName mod)
+ basename = unsafeEncodeUtf $ moduleNameSlashes (moduleName mod)
- to_search :: [(FilePath, ModLocation)]
+ to_search :: [(OsPath, ModLocation)]
to_search = [ (file, fn path basename)
| path <- paths,
(ext,fn) <- exts,
- let base | path == "." = basename
+ let base | path == os "." = basename
| otherwise = path </> basename
file = base <.> ext
]
@@ -543,7 +546,7 @@ searchPathExts paths mod exts = search to_search
else search rest
mkHomeModLocationSearched :: FinderOpts -> ModuleName -> FileExt
- -> FilePath -> BaseName -> ModLocation
+ -> OsPath -> BaseName -> ModLocation
mkHomeModLocationSearched fopts mod suff path basename =
mkHomeModLocation2 fopts mod (path </> basename) suff
@@ -581,18 +584,18 @@ mkHomeModLocationSearched fopts mod suff path basename =
-- ext
-- The filename extension of the source file (usually "hs" or "lhs").
-mkHomeModLocation :: FinderOpts -> ModuleName -> FilePath -> ModLocation
+mkHomeModLocation :: FinderOpts -> ModuleName -> OsPath -> ModLocation
mkHomeModLocation dflags mod src_filename =
- let (basename,extension) = splitExtension src_filename
+ let (basename,extension) = OsPath.splitExtension src_filename
in mkHomeModLocation2 dflags mod basename extension
mkHomeModLocation2 :: FinderOpts
-> ModuleName
- -> FilePath -- Of source module, without suffix
- -> String -- Suffix
+ -> OsPath -- Of source module, without suffix
+ -> FileExt -- Suffix
-> ModLocation
mkHomeModLocation2 fopts mod src_basename ext =
- let mod_basename = moduleNameSlashes mod
+ let mod_basename = unsafeEncodeUtf $ moduleNameSlashes mod
obj_fn = mkObjPath fopts src_basename mod_basename
dyn_obj_fn = mkDynObjPath fopts src_basename mod_basename
@@ -600,51 +603,51 @@ mkHomeModLocation2 fopts mod src_basename ext =
dyn_hi_fn = mkDynHiPath fopts src_basename mod_basename
hie_fn = mkHiePath fopts src_basename mod_basename
- in (ModLocation{ ml_hs_file = Just (src_basename <.> ext),
- ml_hi_file = hi_fn,
- ml_dyn_hi_file = dyn_hi_fn,
- ml_obj_file = obj_fn,
- ml_dyn_obj_file = dyn_obj_fn,
- ml_hie_file = hie_fn })
+ in (OsPathModLocation{ ml_hs_file_ospath = Just (src_basename <.> ext),
+ ml_hi_file_ospath = hi_fn,
+ ml_dyn_hi_file_ospath = dyn_hi_fn,
+ ml_obj_file_ospath = obj_fn,
+ ml_dyn_obj_file_ospath = dyn_obj_fn,
+ ml_hie_file_ospath = hie_fn })
mkHomeModHiOnlyLocation :: FinderOpts
-> ModuleName
- -> FilePath
+ -> OsPath
-> BaseName
-> ModLocation
mkHomeModHiOnlyLocation fopts mod path basename =
- let loc = mkHomeModLocation2 fopts mod (path </> basename) ""
- in loc { ml_hs_file = Nothing }
+ let loc = mkHomeModLocation2 fopts mod (path </> basename) mempty
+ in loc { ml_hs_file_ospath = Nothing }
-- This function is used to make a ModLocation for a package module. Hence why
-- we explicitly pass in the interface file suffixes.
-mkHiOnlyModLocation :: FinderOpts -> Suffix -> Suffix -> FilePath -> String
+mkHiOnlyModLocation :: FinderOpts -> FileExt -> FileExt -> OsPath -> OsPath
-> ModLocation
mkHiOnlyModLocation fopts hisuf dynhisuf path basename
= let full_basename = path </> basename
obj_fn = mkObjPath fopts full_basename basename
dyn_obj_fn = mkDynObjPath fopts full_basename basename
hie_fn = mkHiePath fopts full_basename basename
- in ModLocation{ ml_hs_file = Nothing,
- ml_hi_file = full_basename <.> hisuf,
- -- Remove the .hi-boot suffix from
- -- hi_file, if it had one. We always
- -- want the name of the real .hi file
- -- in the ml_hi_file field.
- ml_dyn_obj_file = dyn_obj_fn,
- -- MP: TODO
- ml_dyn_hi_file = full_basename <.> dynhisuf,
- ml_obj_file = obj_fn,
- ml_hie_file = hie_fn
+ in OsPathModLocation{ ml_hs_file_ospath = Nothing,
+ ml_hi_file_ospath = full_basename <.> hisuf,
+ -- Remove the .hi-boot suffix from
+ -- hi_file, if it had one. We always
+ -- want the name of the real .hi file
+ -- in the ml_hi_file field.
+ ml_dyn_obj_file_ospath = dyn_obj_fn,
+ -- MP: TODO
+ ml_dyn_hi_file_ospath = full_basename <.> dynhisuf,
+ ml_obj_file_ospath = obj_fn,
+ ml_hie_file_ospath = hie_fn
}
-- | Constructs the filename of a .o file for a given source file.
-- Does /not/ check whether the .o file exists
mkObjPath
:: FinderOpts
- -> FilePath -- the filename of the source file, minus the extension
- -> String -- the module name with dots replaced by slashes
- -> FilePath
+ -> OsPath -- the filename of the source file, minus the extension
+ -> OsPath -- the module name with dots replaced by slashes
+ -> OsPath
mkObjPath fopts basename mod_basename = obj_basename <.> osuf
where
odir = finder_objectDir fopts
@@ -657,9 +660,9 @@ mkObjPath fopts basename mod_basename = obj_basename <.> osuf
-- Does /not/ check whether the .dyn_o file exists
mkDynObjPath
:: FinderOpts
- -> FilePath -- the filename of the source file, minus the extension
- -> String -- the module name with dots replaced by slashes
- -> FilePath
+ -> OsPath -- the filename of the source file, minus the extension
+ -> OsPath -- the module name with dots replaced by slashes
+ -> OsPath
mkDynObjPath fopts basename mod_basename = obj_basename <.> dynosuf
where
odir = finder_objectDir fopts
@@ -673,9 +676,9 @@ mkDynObjPath fopts basename mod_basename = obj_basename <.> dynosuf
-- Does /not/ check whether the .hi file exists
mkHiPath
:: FinderOpts
- -> FilePath -- the filename of the source file, minus the extension
- -> String -- the module name with dots replaced by slashes
- -> FilePath
+ -> OsPath -- the filename of the source file, minus the extension
+ -> OsPath -- the module name with dots replaced by slashes
+ -> OsPath
mkHiPath fopts basename mod_basename = hi_basename <.> hisuf
where
hidir = finder_hiDir fopts
@@ -688,9 +691,9 @@ mkHiPath fopts basename mod_basename = hi_basename <.> hisuf
-- Does /not/ check whether the .dyn_hi file exists
mkDynHiPath
:: FinderOpts
- -> FilePath -- the filename of the source file, minus the extension
- -> String -- the module name with dots replaced by slashes
- -> FilePath
+ -> OsPath -- the filename of the source file, minus the extension
+ -> OsPath -- the module name with dots replaced by slashes
+ -> OsPath
mkDynHiPath fopts basename mod_basename = hi_basename <.> dynhisuf
where
hidir = finder_hiDir fopts
@@ -703,9 +706,9 @@ mkDynHiPath fopts basename mod_basename = hi_basename <.> dynhisuf
-- Does /not/ check whether the .hie file exists
mkHiePath
:: FinderOpts
- -> FilePath -- the filename of the source file, minus the extension
- -> String -- the module name with dots replaced by slashes
- -> FilePath
+ -> OsPath -- the filename of the source file, minus the extension
+ -> OsPath -- the module name with dots replaced by slashes
+ -> OsPath
mkHiePath fopts basename mod_basename = hie_basename <.> hiesuf
where
hiedir = finder_hieDir fopts
@@ -726,23 +729,23 @@ mkStubPaths
:: FinderOpts
-> ModuleName
-> ModLocation
- -> FilePath
+ -> OsPath
mkStubPaths fopts mod location
= let
stubdir = finder_stubDir fopts
- mod_basename = moduleNameSlashes mod
- src_basename = dropExtension $ expectJust "mkStubPaths"
- (ml_hs_file location)
+ mod_basename = unsafeEncodeUtf $ moduleNameSlashes mod
+ src_basename = OsPath.dropExtension $ expectJust "mkStubPaths"
+ (ml_hs_file_ospath location)
stub_basename0
| Just dir <- stubdir = dir </> mod_basename
| otherwise = src_basename
- stub_basename = stub_basename0 ++ "_stub"
+ stub_basename = stub_basename0 `mappend` os "_stub"
in
- stub_basename <.> "h"
+ stub_basename <.> os "h"
-- -----------------------------------------------------------------------------
-- findLinkable isn't related to the other stuff in here,
diff --git a/compiler/GHC/Unit/Finder/Types.hs b/compiler/GHC/Unit/Finder/Types.hs
index fceb4b03648c..bf83455a5d7f 100644
--- a/compiler/GHC/Unit/Finder/Types.hs
+++ b/compiler/GHC/Unit/Finder/Types.hs
@@ -9,6 +9,7 @@ where
import GHC.Prelude
import GHC.Unit
+import GHC.Data.OsPath
import qualified Data.Map as M
import GHC.Fingerprint
import GHC.Platform.Ways
@@ -31,7 +32,7 @@ data FinderCache = FinderCache { fcModuleCache :: (IORef FinderCacheState)
data InstalledFindResult
= InstalledFound ModLocation InstalledModule
| InstalledNoPackage UnitId
- | InstalledNotFound [FilePath] (Maybe UnitId)
+ | InstalledNotFound [OsPath] (Maybe UnitId)
-- | The result of searching for an imported module.
--
@@ -70,7 +71,7 @@ data FindResult
--
-- Should be taken from 'DynFlags' via 'initFinderOpts'.
data FinderOpts = FinderOpts
- { finder_importPaths :: [FilePath]
+ { finder_importPaths :: [OsPath]
-- ^ Where are we allowed to look for Modules and Source files
, finder_lookupHomeInterfaces :: Bool
-- ^ When looking up a home module:
@@ -88,17 +89,17 @@ data FinderOpts = FinderOpts
, finder_enableSuggestions :: Bool
-- ^ If we encounter unknown modules, should we suggest modules
-- that have a similar name.
- , finder_workingDirectory :: Maybe FilePath
+ , finder_workingDirectory :: Maybe OsPath
, finder_thisPackageName :: Maybe FastString
, finder_hiddenModules :: Set.Set ModuleName
, finder_reexportedModules :: Set.Set ModuleName
- , finder_hieDir :: Maybe FilePath
- , finder_hieSuf :: String
- , finder_hiDir :: Maybe FilePath
- , finder_hiSuf :: String
- , finder_dynHiSuf :: String
- , finder_objectDir :: Maybe FilePath
- , finder_objectSuf :: String
- , finder_dynObjectSuf :: String
- , finder_stubDir :: Maybe FilePath
+ , finder_hieDir :: Maybe OsPath
+ , finder_hieSuf :: OsString
+ , finder_hiDir :: Maybe OsPath
+ , finder_hiSuf :: OsString
+ , finder_dynHiSuf :: OsString
+ , finder_objectDir :: Maybe OsPath
+ , finder_objectSuf :: OsString
+ , finder_dynObjectSuf :: OsString
+ , finder_stubDir :: Maybe OsPath
} deriving Show
diff --git a/compiler/GHC/Unit/Module/Location.hs b/compiler/GHC/Unit/Module/Location.hs
index 4d70b43b21ac..3c14fad2cc14 100644
--- a/compiler/GHC/Unit/Module/Location.hs
+++ b/compiler/GHC/Unit/Module/Location.hs
@@ -1,6 +1,17 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
-- | Module location
module GHC.Unit.Module.Location
- ( ModLocation(..)
+ ( ModLocation
+ ( ..
+ , ml_hs_file
+ , ml_hi_file
+ , ml_dyn_hi_file
+ , ml_obj_file
+ , ml_dyn_obj_file
+ , ml_hie_file
+ )
+ , pattern ModLocation
, addBootSuffix
, addBootSuffix_maybe
, addBootSuffixLocn_maybe
@@ -11,15 +22,19 @@ module GHC.Unit.Module.Location
where
import GHC.Prelude
+
+import GHC.Data.OsPath
import GHC.Unit.Types
import GHC.Utils.Outputable
+import qualified System.OsString as OsString
+
-- | Module Location
--
-- Where a module lives on the file system: the actual locations
-- of the .hs, .hi, .dyn_hi, .o, .dyn_o and .hie files, if we have them.
--
--- For a module in another unit, the ml_hs_file and ml_obj_file components of
+-- For a module in another unit, the ml_hs_file_ospath and ml_obj_file_ospath components of
-- ModLocation are undefined.
--
-- The locations specified by a ModLocation may or may not
@@ -38,31 +53,31 @@ import GHC.Utils.Outputable
-- boot suffixes in mkOneShotModLocation.
data ModLocation
- = ModLocation {
- ml_hs_file :: Maybe FilePath,
+ = OsPathModLocation {
+ ml_hs_file_ospath :: Maybe OsPath,
-- ^ The source file, if we have one. Package modules
-- probably don't have source files.
- ml_hi_file :: FilePath,
+ ml_hi_file_ospath :: OsPath,
-- ^ Where the .hi file is, whether or not it exists
-- yet. Always of form foo.hi, even if there is an
-- hi-boot file (we add the -boot suffix later)
- ml_dyn_hi_file :: FilePath,
+ ml_dyn_hi_file_ospath :: OsPath,
-- ^ Where the .dyn_hi file is, whether or not it exists
-- yet.
- ml_obj_file :: FilePath,
+ ml_obj_file_ospath :: OsPath,
-- ^ Where the .o file is, whether or not it exists yet.
-- (might not exist either because the module hasn't
-- been compiled yet, or because it is part of a
-- unit with a .a file)
- ml_dyn_obj_file :: FilePath,
+ ml_dyn_obj_file_ospath :: OsPath,
-- ^ Where the .dy file is, whether or not it exists
-- yet.
- ml_hie_file :: FilePath
+ ml_hie_file_ospath :: OsPath
-- ^ Where the .hie file is, whether or not it exists
-- yet.
} deriving Show
@@ -71,18 +86,18 @@ instance Outputable ModLocation where
ppr = text . show
-- | Add the @-boot@ suffix to .hs, .hi and .o files
-addBootSuffix :: FilePath -> FilePath
-addBootSuffix path = path ++ "-boot"
+addBootSuffix :: OsPath -> OsPath
+addBootSuffix path = path `mappend` os "-boot"
-- | Remove the @-boot@ suffix to .hs, .hi and .o files
-removeBootSuffix :: FilePath -> FilePath
-removeBootSuffix "-boot" = []
-removeBootSuffix (x:xs) = x : removeBootSuffix xs
-removeBootSuffix [] = error "removeBootSuffix: no -boot suffix"
-
+removeBootSuffix :: OsPath -> OsPath
+removeBootSuffix pathWithBootSuffix =
+ case OsString.stripSuffix (os "-boot") pathWithBootSuffix of
+ Just path -> path
+ Nothing -> error "removeBootSuffix: no -boot suffix"
-- | Add the @-boot@ suffix if the @Bool@ argument is @True@
-addBootSuffix_maybe :: IsBootInterface -> FilePath -> FilePath
+addBootSuffix_maybe :: IsBootInterface -> OsPath -> OsPath
addBootSuffix_maybe is_boot path = case is_boot of
IsBoot -> addBootSuffix path
NotBoot -> path
@@ -95,22 +110,50 @@ addBootSuffixLocn_maybe is_boot locn = case is_boot of
-- | Add the @-boot@ suffix to all file paths associated with the module
addBootSuffixLocn :: ModLocation -> ModLocation
addBootSuffixLocn locn
- = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn)
- , ml_hi_file = addBootSuffix (ml_hi_file locn)
- , ml_dyn_hi_file = addBootSuffix (ml_dyn_hi_file locn)
- , ml_obj_file = addBootSuffix (ml_obj_file locn)
- , ml_dyn_obj_file = addBootSuffix (ml_dyn_obj_file locn)
- , ml_hie_file = addBootSuffix (ml_hie_file locn) }
+ = locn { ml_hs_file_ospath = fmap addBootSuffix (ml_hs_file_ospath locn)
+ , ml_hi_file_ospath = addBootSuffix (ml_hi_file_ospath locn)
+ , ml_dyn_hi_file_ospath = addBootSuffix (ml_dyn_hi_file_ospath locn)
+ , ml_obj_file_ospath = addBootSuffix (ml_obj_file_ospath locn)
+ , ml_dyn_obj_file_ospath = addBootSuffix (ml_dyn_obj_file_ospath locn)
+ , ml_hie_file_ospath = addBootSuffix (ml_hie_file_ospath locn) }
-- | Add the @-boot@ suffix to all output file paths associated with the
-- module, not including the input file itself
addBootSuffixLocnOut :: ModLocation -> ModLocation
addBootSuffixLocnOut locn
- = locn { ml_hi_file = addBootSuffix (ml_hi_file locn)
- , ml_dyn_hi_file = addBootSuffix (ml_dyn_hi_file locn)
- , ml_obj_file = addBootSuffix (ml_obj_file locn)
- , ml_dyn_obj_file = addBootSuffix (ml_dyn_obj_file locn)
- , ml_hie_file = addBootSuffix (ml_hie_file locn)
+ = locn { ml_hi_file_ospath = addBootSuffix (ml_hi_file_ospath locn)
+ , ml_dyn_hi_file_ospath = addBootSuffix (ml_dyn_hi_file_ospath locn)
+ , ml_obj_file_ospath = addBootSuffix (ml_obj_file_ospath locn)
+ , ml_dyn_obj_file_ospath = addBootSuffix (ml_dyn_obj_file_ospath locn)
+ , ml_hie_file_ospath = addBootSuffix (ml_hie_file_ospath locn)
}
-
+-- ----------------------------------------------------------------------------
+-- Helpers for backwards compatibility
+-- ----------------------------------------------------------------------------
+
+pattern ModLocation :: Maybe FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> FilePath -> ModLocation
+pattern ModLocation
+ { ml_hs_file
+ , ml_hi_file
+ , ml_dyn_hi_file
+ , ml_obj_file
+ , ml_dyn_obj_file
+ , ml_hie_file
+ } <- OsPathModLocation
+ { ml_hs_file_ospath = (fmap unsafeDecodeUtf -> ml_hs_file)
+ , ml_hi_file_ospath = (unsafeDecodeUtf -> ml_hi_file)
+ , ml_dyn_hi_file_ospath = (unsafeDecodeUtf -> ml_dyn_hi_file)
+ , ml_obj_file_ospath = (unsafeDecodeUtf -> ml_obj_file)
+ , ml_dyn_obj_file_ospath = (unsafeDecodeUtf -> ml_dyn_obj_file)
+ , ml_hie_file_ospath = (unsafeDecodeUtf -> ml_hie_file)
+ } where
+ ModLocation ml_hs_file ml_hi_file ml_dyn_hi_file ml_obj_file ml_dyn_obj_file ml_hie_file
+ = OsPathModLocation
+ { ml_hs_file_ospath = fmap unsafeEncodeUtf ml_hs_file
+ , ml_hi_file_ospath = unsafeEncodeUtf ml_hi_file
+ , ml_dyn_hi_file_ospath = unsafeEncodeUtf ml_dyn_hi_file
+ , ml_obj_file_ospath = unsafeEncodeUtf ml_obj_file
+ , ml_dyn_obj_file_ospath = unsafeEncodeUtf ml_dyn_obj_file
+ , ml_hie_file_ospath = unsafeEncodeUtf ml_hie_file
+ }
diff --git a/compiler/GHC/Unit/Module/ModSummary.hs b/compiler/GHC/Unit/Module/ModSummary.hs
index 46468c0b545a..d2f878bd1563 100644
--- a/compiler/GHC/Unit/Module/ModSummary.hs
+++ b/compiler/GHC/Unit/Module/ModSummary.hs
@@ -17,6 +17,11 @@ module GHC.Unit.Module.ModSummary
, msHsFilePath
, msObjFilePath
, msDynObjFilePath
+ , msHsFileOsPath
+ , msHiFileOsPath
+ , msDynHiFileOsPath
+ , msObjFileOsPath
+ , msDynObjFileOsPath
, msDeps
, isBootSummary
, findTarget
@@ -38,6 +43,7 @@ import GHC.Types.Target
import GHC.Types.PkgQual
import GHC.Data.Maybe
+import GHC.Data.OsPath (OsPath)
import GHC.Data.StringBuffer ( StringBuffer )
import GHC.Utils.Fingerprint
@@ -146,6 +152,13 @@ msDynHiFilePath ms = ml_dyn_hi_file (ms_location ms)
msObjFilePath ms = ml_obj_file (ms_location ms)
msDynObjFilePath ms = ml_dyn_obj_file (ms_location ms)
+msHsFileOsPath, msDynHiFileOsPath, msHiFileOsPath, msObjFileOsPath, msDynObjFileOsPath :: ModSummary -> OsPath
+msHsFileOsPath ms = expectJust "msHsFilePath" (ml_hs_file_ospath (ms_location ms))
+msHiFileOsPath ms = ml_hi_file_ospath (ms_location ms)
+msDynHiFileOsPath ms = ml_dyn_hi_file_ospath (ms_location ms)
+msObjFileOsPath ms = ml_obj_file_ospath (ms_location ms)
+msDynObjFileOsPath ms = ml_dyn_obj_file_ospath (ms_location ms)
+
-- | Did this 'ModSummary' originate from a hs-boot file?
isBootSummary :: ModSummary -> IsBootInterface
isBootSummary ms = if ms_hsc_src ms == HsBootFile then IsBoot else NotBoot
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index f59b69ff7d33..68d3502712fc 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -123,7 +123,8 @@ Library
time >= 1.4 && < 1.15,
containers >= 0.6.2.1 && < 0.8,
array >= 0.1 && < 0.6,
- filepath >= 1 && < 1.6,
+ filepath >= 1.5 && < 1.6,
+ os-string >= 2.0.1 && < 2.1,
hpc >= 0.6 && < 0.8,
transformers >= 0.5 && < 0.7,
exceptions == 0.10.*,
@@ -444,6 +445,7 @@ Library
GHC.Data.List.SetOps
GHC.Data.Maybe
GHC.Data.OrdList
+ GHC.Data.OsPath
GHC.Data.Pair
GHC.Data.SmallArray
GHC.Data.Stream
diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in
index 38841a9aa35a..29132d87f83e 100644
--- a/ghc/ghc-bin.cabal.in
+++ b/ghc/ghc-bin.cabal.in
@@ -36,7 +36,7 @@ Executable ghc
bytestring >= 0.9 && < 0.13,
directory >= 1 && < 1.4,
process >= 1 && < 1.7,
- filepath >= 1 && < 1.6,
+ filepath >= 1.5 && < 1.6,
containers >= 0.5 && < 0.8,
transformers >= 0.5 && < 0.7,
ghc-boot == @ProjectVersionMunged@,
diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout
index 4f1f5abe01c0..4bcac20320ab 100644
--- a/testsuite/tests/count-deps/CountDepsAst.stdout
+++ b/testsuite/tests/count-deps/CountDepsAst.stdout
@@ -70,6 +70,7 @@ GHC.Data.List.Infinite
GHC.Data.List.SetOps
GHC.Data.Maybe
GHC.Data.OrdList
+GHC.Data.OsPath
GHC.Data.Pair
GHC.Data.SmallArray
GHC.Data.Strict
diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout
index 570b8880efc1..46047e5b3f29 100644
--- a/testsuite/tests/count-deps/CountDepsParser.stdout
+++ b/testsuite/tests/count-deps/CountDepsParser.stdout
@@ -71,6 +71,7 @@ GHC.Data.List.Infinite
GHC.Data.List.SetOps
GHC.Data.Maybe
GHC.Data.OrdList
+GHC.Data.OsPath
GHC.Data.Pair
GHC.Data.SmallArray
GHC.Data.Strict
diff --git a/utils/haddock/haddock-api/src/Haddock/Interface/Create.hs b/utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
index df63ba98f1ec..e37bba75535d 100644
--- a/utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
+++ b/utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
@@ -93,10 +93,7 @@ createInterface1 flags unit_state mod_sum mod_iface ifaces inst_ifaces (instance
-- pragmas in the modules source code. Used to infer
-- safety of module.
ms_hspp_opts
- , ms_location =
- ModLocation
- { ml_hie_file
- }
+ , ms_location = modl
} = mod_sum
dflags = ms_hspp_opts
@@ -228,7 +225,7 @@ createInterface1 flags unit_state mod_sum mod_iface ifaces inst_ifaces (instance
Interface
{ ifaceMod = mdl
, ifaceIsSig = is_sig
- , ifaceHieFile = ml_hie_file
+ , ifaceHieFile = ml_hie_file modl
, ifaceInfo = info
, ifaceDoc = Documentation header_doc mod_warning
, ifaceRnDoc = Documentation Nothing Nothing
--
GitLab