Merge pull request #6299 from commercialhaskell/stan

Clear a STAN suggestion
commercialhaskell · Oct 17, 2023 · 87c1a5b · 87c1a5b
2 parents de28cfa + da36a0b
commit 87c1a5b
Show file tree

Hide file tree

Showing 2 changed files with 37 additions and 13 deletions.
diff --git a/src/Path/Extra.hs b/src/Path/Extra.hs
@@ -4,7 +4,6 @@
 -- | Extra Path utilities.
 module Path.Extra
   ( toFilePathNoTrailingSep
-  , dropRoot
   , parseCollapsedAbsDir
   , parseCollapsedAbsFile
   , concatAndCollapseAbsDir
@@ -17,6 +16,10 @@ module Path.Extra
   , forgivingResolveDir
   , forgivingResolveFile
   , forgivingResolveFile'
+  , splitDrive
+  , takeDrive
+  , dropDrive
+  , isDrive
   ) where
 
 import           Data.Time ( UTCTime )
@@ -89,11 +92,6 @@ collapseFilePath = FP.joinPath . reverse . foldl' go [] . FP.splitDirectories
   checkPathSeparator [x] = FP.isPathSeparator x
   checkPathSeparator _ = False
 
--- | Drop the root (either @\/@ on POSIX or @C:\\@, @D:\\@, etc. on
--- Windows).
-dropRoot :: Path Abs t -> Path Rel t
-dropRoot (Path l) = Path (FP.dropDrive l)
-
 -- | If given file in 'Maybe' does not exist, ensure we have 'Nothing'. This
 -- is to be used in conjunction with 'forgivingAbsence' and
 -- 'resolveFile'.
@@ -183,3 +181,31 @@ forgivingResolveFile' ::
      -- ^ Path to resolve
   -> m (Maybe (Path Abs File))
 forgivingResolveFile' p = getCurrentDir >>= flip forgivingResolveFile p
+
+-- The following functions may be added to a future version of the path package.
+-- See https://github.com/commercialhaskell/path/pull/191
+
+-- | Split an absolute path into a drive and, perhaps, a path. On POSIX, @/@ is
+-- a drive.
+splitDrive :: Path Abs t -> (Path Abs Dir, Maybe (Path Rel t))
+splitDrive (Path fp) =
+    let (d, rest) = FP.splitDrive fp
+        mRest = if null rest then Nothing else Just (Path rest)
+    in  (Path d, mRest)
+
+-- | Get the drive from an absolute path. On POSIX, @/@ is a drive.
+--
+-- > takeDrive x = fst (splitDrive x)
+takeDrive :: Path Abs t -> Path Abs Dir
+takeDrive = fst . splitDrive
+
+-- | Drop the drive from an absolute path. May result in 'Nothing' if the path
+-- is just a drive.
+--
+-- > dropDrive x = snd (splitDrive x)
+dropDrive :: Path Abs t -> Maybe (Path Rel t)
+dropDrive = snd . splitDrive
+
+-- | Is an absolute directory path a drive?
+isDrive :: Path Abs Dir -> Bool
+isDrive = isNothing . dropDrive
diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs
@@ -43,7 +43,6 @@ import           Data.Conduit.Process.Typed ( createSource )
 import           Data.Conduit.Zlib ( ungzip )
 import           Data.List.Split ( splitOn )
 import qualified Data.Map as Map
-import           Data.Maybe ( fromJust )
 import qualified Data.Set as Set
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
@@ -66,13 +65,12 @@ import           Network.HTTP.StackClient
                    )
 import           Network.HTTP.Simple ( getResponseHeader )
 import           Path
-                   ( (</>), addExtension, filename, fromAbsDir, parent
-                   , parseAbsDir, parseAbsFile, parseRelDir, parseRelFile
-                   , toFilePath
+                   ( (</>), addExtension, filename, parent, parseAbsDir
+                   , parseAbsFile, parseRelDir, parseRelFile, toFilePath
                    )
 import           Path.CheckInstall ( warnInstallSearchPathIssues )
 import           Path.Extended ( fileExtension )
-import           Path.Extra ( toFilePathNoTrailingSep )
+import           Path.Extra ( takeDrive, toFilePathNoTrailingSep )
 import           Path.IO
                    ( canonicalizePath, doesFileExist, ensureDir, executable
                    , getPermissions, ignoringAbsence, listDir, removeDirRecur
@@ -167,7 +165,7 @@ import           Stack.Types.VersionedDownloadInfo
 import qualified System.Directory as D
 import           System.Environment ( getExecutablePath, lookupEnv )
 import           System.IO.Error ( isPermissionError )
-import           System.FilePath ( searchPathSeparator, takeDrive )
+import           System.FilePath ( searchPathSeparator )
 import qualified System.FilePath as FP
 import           System.Permissions ( setFileExecutable )
 import           System.Uname ( getRelease )
@@ -2351,7 +2349,7 @@ withUnpackedTarball7z name si archiveFile archiveType destDir = do
   -- filepath length of more than 260 characters, which can be problematic for
   -- 7-Zip even if Long Filepaths are enabled on Windows.
   let tmpName = "stack-tmp"
-      destDrive = fromJust $ parseAbsDir $ takeDrive $ fromAbsDir destDir
+      destDrive = takeDrive destDir
   ensureDir (parent destDir)
   withRunInIO $ \run ->
   -- We use a temporary directory in the same drive as that of 'destDir' to