Convert FilePath to OsPath in Types/Args.hs

Author: facundominguez

ghc-server/lib/GhcServer/Cache.hs

@@ -29,6 +29,7 @@ import GhcServer.Data.Unit (Project (..), Unit (..), UnitCache (..), UnitDepNode
 import GhcServer.Path (fromOsPath, toOsPath)
 import System.Directory (doesFileExist)
 import System.Directory.OsPath (createDirectoryIfMissing)
+import qualified System.Directory.OsPath as OsPath (doesFileExist)
 import qualified System.File.OsPath as OsFile
 import System.OsPath (OsPath, (</>))
 import Types.CachedDeps (CachedBuildPlan (..), CachedBuildPlans (..), CachedUnit (..), JsonFs (..))
@@ -82,7 +83,7 @@ writeUnitCache _logger unitCache depPlans buildPlanPath ghcOptions =
 -- | Check whether a cache exists for a unit.
 cacheExists :: UnitCache -> IO Bool
 cacheExists unitCache =
-  doesFileExist unitCache.cachedUnitPath
+  OsPath.doesFileExist unitCache.cachedUnitPath
 
 -- | Order the transitive dependencies of a unit for loading by 'loadCachedUnits'.
 --
@@ -122,12 +123,12 @@ depLoadOrder depGraph root =
 -- @cached_unit.json@ files.
 buildDepPlans :: Graph UnitDepNode -> Unit -> IO CachedBuildPlans
 buildDepPlans depGraph unit =
-  CachedBuildPlans . fmap plan <$> filterM (doesFileExist . (.node_payload)) (depLoadOrder depGraph selfNode)
+  CachedBuildPlans . fmap plan <$> filterM (OsPath.doesFileExist . (.node_payload)) (depLoadOrder depGraph selfNode)
   where
     plan node =
       CachedBuildPlan {
         name = JsonFs (toUnitId (stringToUnit node.node_key.string)),
-        build_plan = node.node_payload
+        build_plan = fromOsPath node.node_payload
       }
 
     selfNode = Graph.DigraphNode {
@@ -140,16 +141,16 @@ buildDepPlans depGraph unit =
 -- | If the unit's @cached_unit.json@ exists from a prior build, return its path.
 --
 -- This is used before compilation to let 'withGhcMakeModule' restore the home unit via 'loadHomeUnit'.
-loadHomeUnitCache :: UnitCache -> IO (Maybe FilePath)
+loadHomeUnitCache :: UnitCache -> IO (Maybe OsPath)
 loadHomeUnitCache unitCache =
-  whenMaybeM (doesFileExist unitCache.cachedUnitPath) (pure unitCache.cachedUnitPath)
+  whenMaybeM (OsPath.doesFileExist unitCache.cachedUnitPath) (pure unitCache.cachedUnitPath)
 
 -- | Check whether a module's interface file (@.dyn_hi@) exists.
 --
 -- The interface file is the reliable indicator that a module was compiled in a prior build.
 interfaceExists :: OsPath -> UnitName -> ModuleName -> IO Bool
 interfaceExists outputDir name modName =
-  doesFileExist (moduleHiPath outputDir name modName)
+  OsPath.doesFileExist (moduleHiPath outputDir name modName)
 
 -- | Compute the set of all units with cache from a prior build.
 cachedUnitsForProject :: Project -> IO (Set UnitName)
@@ -179,12 +180,12 @@ mkBuildCache outputDir project =
 -- @Left err@ on decode failure.
 loadCachedUnit :: UnitCache -> IO (Either String (Maybe CachedUnit))
 loadCachedUnit unitCache =
-  doesFileExist unitCache.cachedUnitPath >>= \case
+  OsPath.doesFileExist unitCache.cachedUnitPath >>= \case
     False -> pure (Right Nothing)
     True ->
-      eitherDecodeFileStrict' unitCache.cachedUnitPath >>= \case
+      eitherDecodeFileStrict' (fromOsPath unitCache.cachedUnitPath) >>= \case
         Left err ->
-          pure (Left ("Failed to decode cached unit " ++ unitCache.cachedUnitPath ++ ": " ++ err))
+          pure (Left ("Failed to decode cached unit " ++ fromOsPath unitCache.cachedUnitPath ++ ": " ++ err))
         Right cu -> pure (Right (Just cu))
 
 

ghc-server/lib/GhcServer/Data/Unit.hs

@@ -35,7 +35,7 @@ data UnitCache =
     -- | The cache subdirectory for this unit (@cache/unitName/@).
     dir :: OsPath,
     -- | Path to @cached_unit.json@.
-    cachedUnitPath :: FilePath,
+    cachedUnitPath :: OsPath,
     -- | Path to @unit_args@.
     unitArgsPath :: FilePath,
     -- | Path to @dep_units.json@.
@@ -46,9 +46,9 @@ data UnitCache =
 -- | Compute the absolute path to a module's @.dyn_hi@ file.
 --
 -- The path is @outputDir/unitId/ModuleName.dyn_hi@.
-moduleHiPath :: OsPath -> UnitName -> ModuleName -> FilePath
+moduleHiPath :: OsPath -> UnitName -> ModuleName -> OsPath
 moduleHiPath outputDir name modName =
-  fromOsPath (outputDir </> toOsPath (unitIdString (unitId name)) </> toOsPath (moduleNameString modName ++ ".dyn_hi"))
+  outputDir </> toOsPath (unitIdString (unitId name)) </> toOsPath (moduleNameString modName ++ ".dyn_hi")
 
 -- | A unit discovered in the project, identified by its directory name.
 data Unit =
@@ -72,7 +72,7 @@ data Unit =
 --
 -- Each node's key is the 'UnitName'; its payload is the unit's own cache path
 -- (used when building 'CachedBuildPlans' from the transitive closure).
-type UnitDepNode = Graph.Node UnitName FilePath
+type UnitDepNode = Graph.Node UnitName OsPath
 
 -- | A project is the collection of all units in the build root.
 data Project =
@@ -106,7 +106,7 @@ mkUnitCache :: OsPath -> UnitName -> UnitCache
 mkUnitCache projectRoot name =
   UnitCache {
     dir = cDir,
-    cachedUnitPath = fromOsPath (cDir </> toOsPath "cached_unit.json"),
+    cachedUnitPath = cDir </> toOsPath "cached_unit.json",
     unitArgsPath = fromOsPath (cDir </> toOsPath "unit_args"),
     depUnitsPath = fromOsPath (cDir </> toOsPath "dep_units.json")
   }

internal/src/Internal/Cache/Hpt.hs

@@ -40,6 +40,8 @@ import Types.BuckArgs (decodeJsonArg)
 import Types.CachedDeps (CachedDep (..), CachedDeps (..), CachedUnit (..), JsonFs (..))
 import Types.Log (Logger (..))
 import Types.State (WorkerState)
+import System.OsPath (OsPath)
+import System.OsPath.Extra (toOsPath)
 
 #if RECENT || defined(MWB)
 
@@ -226,7 +228,7 @@ loadHomeUnit ::
   DynFlags ->
   UnitId ->
   HscEnv ->
-  FilePath ->
+  OsPath ->
   IO HscEnv
 loadHomeUnit log stateVar dflags0 unit hsc_env0 path
   | hasUnit unit hsc_env0
@@ -235,7 +237,7 @@ loadHomeUnit log stateVar dflags0 unit hsc_env0 path
   = do
     cachedUnit@CachedUnit {unit_args} <- decodeJsonArg "--home-unit" path
     hsc_env1 <- fmap (fromMaybe hsc_env0) $ for cachedUnit.dep_units \ file -> do
-      deps <- decodeJsonArg "--home-unit" file
+      deps <- decodeJsonArg "--home-unit" (toOsPath file)
       loadCachedUnits log stateVar dflags0 deps hsc_env0
     dflags <- maybe (pure dflags0) (readParseGHCArgs hsc_env1 dflags0) unit_args
 

ops/packages.nix

@@ -218,6 +218,7 @@
           "filepath"
           "ghc"
           "ghc-paths"
+          "os-string"
           "split"
           "text"
         ];

test-common/lib/Test/Cache.hs

@@ -142,7 +142,7 @@ moduleCache ::
   SessionEnv ->
   ModuleKey ->
   Set TaskKey ->
-  (FilePath, CachedDeps)
+  (OsPath, CachedDeps)
 moduleCache env key deps =
   (unitPath, CachedDeps (mkCachedDep <$> depKeys))
   where
@@ -153,7 +153,7 @@ moduleCache env key deps =
         interfaces = interfacePath dc :| []
       }
 
-    unitPath = fp (env.tempDir </> cachedUnitPath key.unit)
+    unitPath = env.tempDir </> cachedUnitPath key.unit
 
     depKeys = [m | TaskCompile m <- Set.toList deps]
 

test-common/lib/Test/Data/Project.hs

@@ -6,6 +6,7 @@ import Data.Set (Set)
 import Numeric.Natural (Natural)
 import Test.Data.Scheduler (Task (..))
 import Types.CachedDeps (CachedBuildPlans, CachedDeps)
+import System.OsPath (OsPath)
 
 -- | Error variant for modules that should fail compilation.
 -- The variant determines both the generated source expression and the expected GHC diagnostic code.
@@ -132,7 +133,7 @@ data UnitCache =
 data ModuleCache =
   ModuleCache {
     -- | The home unit's build plan and arguments.
-    cachedUnit :: FilePath,
+    cachedUnit :: OsPath,
 
     -- | The interfaces of the dependency closure across the project.
     -- Decoded outside of worker handlers, so no JSON file.

types/src/Types/Args.hs

@@ -97,7 +97,7 @@ data Args =
     ghcOptions :: [String],
     cachedBuildPlans :: Maybe CachedBuildPlans,
     cachedDeps :: Maybe CachedDeps,
-    homeUnit :: Maybe FilePath
+    homeUnit :: Maybe OsPath
   }
   deriving stock (Eq, Show)
 

types/src/Types/BuckArgs.hs

@@ -17,7 +17,8 @@ import GHC (mkModule, mkModuleName)
 import GHC.Paths (libdir)
 import GHC.Unit (Definite (..), GenUnit (RealUnit), stringToUnitId)
 import System.FilePath (takeDirectory)
-import System.OsPath (encodeFS)
+import System.OsPath (OsPath, encodeUtf, encodeFS)
+import System.OsPath.Extra (fromOsPath, toOsPath)
 import qualified Types.Args
 import Types.Args (
   Args (Args),
@@ -62,7 +63,7 @@ data BuckArgs =
     moduleName :: Maybe String,
     depModules :: Maybe String,
     depUnits :: Maybe String,
-    homeUnit :: Maybe String,
+    homeUnit :: Maybe OsPath,
     workerTargetId :: Maybe TargetId,
     pluginDb :: Maybe String,
     env :: Map String String,
@@ -120,7 +121,7 @@ options =
     withArg "--buck2-packagedb-dep" \ z a -> z {buck2PackageDbDep = Just a},
     withArg "--dep-modules" \ z a -> z {depModules = Just a},
     withArg "--dep-units" \ z a -> z {depUnits = Just a},
-    withArg "--home-unit" \ z a -> z {homeUnit = Just a},
+    withOsPathArg "--home-unit" \ z a -> z {homeUnit = Just a},
     withArg "--extra-env-key" \ z a -> z {envKey = Just a},
     withArgErr "--extra-env-value" \ z a -> addEnv z a,
     withArg "--worker-target-id" \ z a -> z {workerTargetId = Just (TargetId a)},
@@ -153,12 +154,18 @@ options =
 
     withArgErr name f = (name, \ argv z -> takeArg name argv (f z))
 
+    withOsPathArg name f = (name, \ argv z -> takeOsPathArg name argv (Right . f z))
+
     takeArg name argv store = case argv of
       [] -> Left (name ++ " needs an argument")
       arg : rest -> do
         new <- store arg
         Right (rest, new)
 
+    takeOsPathArg name argv store = takeArg name argv $ \arg -> case encodeUtf arg of
+      Left e -> Left ("could not encode " ++ name ++ "=" ++ arg ++ ": " ++ show e)
+      Right p -> store p
+
 parseBuckArgs :: CommandEnv -> RequestArgs -> Either String BuckArgs
 parseBuckArgs env =
   spin (emptyBuckArgs (coerce env)) . coerce
@@ -184,12 +191,12 @@ parseBuckArgs env =
 decodeJsonArg ::
   FromJSON a =>
   String ->
-  String ->
+  OsPath ->
   IO a
 decodeJsonArg desc file =
-  eitherDecodeFileStrict' file >>= \case
+  eitherDecodeFileStrict' (fromOsPath file) >>= \case
     Right a -> pure a
-    Left err -> throwIO (userError ("Invalid JSON in file for " ++ desc ++ ": " ++ err ++ " (" ++ file ++ ")"))
+    Left err -> throwIO (userError ("Invalid JSON in file for " ++ desc ++ ": " ++ err ++ " (" ++ fromOsPath file ++ ")"))
 
 -- | @CompileHpt@ can either process a source file or pick a previously constructed @ModSummary@ from the module graph.
 -- In the latter case, we need both a unit ID and a module name, which is ensured here.
@@ -217,8 +224,8 @@ parseField = \case
 
 toGhcArgs :: BuckArgs -> IO Args
 toGhcArgs args = do
-  cachedDeps <- traverse (decodeJsonArg "--dep-modules") args.depModules
-  cachedBuildPlans <- traverse (decodeJsonArg "--dep-units") args.depUnits
+  cachedDeps <- traverse (decodeJsonArg "--dep-modules" . toOsPath) args.depModules
+  cachedBuildPlans <- traverse (decodeJsonArg "--dep-units" . toOsPath) args.depUnits
   -- Buck specifies @-B@, which can be used to include more packages in the global package DB.
   -- While this is done by @ghcWithPackages@ from nixpkgs, it is likely redundant, but doesn't hurt.
   -- In any case, we default to @libdir@ from @ghc-paths@, which returns the directory in the distribution used by the