Fix #190 Add splitDrive, takeDrive, dropDrive and isDrive

.github/workflows/ci.yaml

@@ -1,4 +1,3 @@
-
 name: CI
 
 # Trigger the workflow on push or pull request, but only for the master branch
@@ -14,18 +13,22 @@ jobs:
     strategy:
       matrix:
         os: [ubuntu-latest, macOS-latest, windows-latest]
-        cabal: ["3.4"]
+        cabal: ["3.10"]
         ghc:
-          - "8.8.4"
-          - "8.10.4"
-          - "9.0.1"
+          # GHC versions listed as current stable releases
+          - "9.2.8"
+          - "9.4.7"
+          - "9.6.3"
+        # GHC 9.8 only works with cabal-install >= 3.10.2.0, which is not
+        # available from haskell-actions/setup (or on Hackage)
+        # - "9.8.1"
 
     steps:
-    - uses: actions/checkout@v2
+    - uses: actions/checkout@v4
 
-    - uses: haskell/actions/setup@v1.2
+    - uses: haskell-actions/setup@v2
       id: setup-haskell-cabal
-      name: Setup Haskell
+      name: Setup GHC and cabal-install
       with:
         ghc-version: ${{ matrix.ghc }}
         cabal-version: ${{ matrix.cabal }}
@@ -38,7 +41,7 @@ jobs:
       run: |
         cabal freeze
 
-    - uses: actions/cache@v2.1.3
+    - uses: actions/cache@v3
       name: Cache ~/.cabal/store
       with:
         path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }}
@@ -52,33 +55,29 @@ jobs:
       run: |
         cabal build all
 
-    - name: Test
+    - name: Test the test-suite test
       run: |
         cabal test path:test
 
-    # - name: Test
-    #   run: |
-    #     cabal test path:validity-test
+  # - name: Test the test-suite validity-test
+  #   run: |
+  #     cabal test path:validity-test
 
+  # As of 2023-10-16, the GitHub-hosted runner on ubuntu-latest comes with
+  # Stack 2.13.1 and GHC 9.6.3.
   stack:
     name: stack / ghc ${{ matrix.ghc }}
     runs-on: ubuntu-latest
     strategy:
       matrix:
-        stack: ["2.3.1"]
-        ghc: ["8.8.4"]
+        ghc: ["9.6.3"]
 
     steps:
-    - uses: actions/checkout@v2
-
-    - uses: haskell/actions/[email protected]
-      name: Setup Haskell Stack
-      with:
-        ghc-version: ${{ matrix.ghc }}
-        stack-version: ${{ matrix.stack }}
+    - name: Clone project
+      uses: actions/checkout@v4
 
-    - uses: actions/[email protected]
-      name: Cache ~/.stack
+    - name: Cache Stack root
+      uses: actions/cache@v3
       with:
         path: ~/.stack
         key: ${{ runner.os }}-${{ matrix.ghc }}-stack
@@ -91,10 +90,10 @@ jobs:
       run: |
         stack build --system-ghc --test --bench --no-run-tests --no-run-benchmarks
 
-    - name: Test
+    - name: Test the test-suite test
       run: |
-        stack test --system-ghc :test
+        stack test path:test:test --system-ghc
 
-        # - name: Test
-        #   run: |
-        #     stack test --system-ghc :validity-test
+  # - name: Test the test-suite validity-test
+  #   run: |
+  #     stack test path:test:validity-test --system-ghc

CHANGELOG

@@ -1,3 +1,6 @@
+0.9.3
+  * Add `splitDrive`, `takeDrive`, `dropDrive` and `isDrive`.
+
 0.9.2
   * Data instances for Rel, Abs, File, and Dir.
   * Bump hashable upper bound to <1.5.

path.cabal

@@ -1,5 +1,5 @@
 name:                path
-version:             0.9.2
+version:             0.9.3
 synopsis:            Support for well-typed paths
 description:         Support for well-typed paths.
 license:             BSD3

src/Path/Include.hs

@@ -63,6 +63,10 @@
   ,splitExtension
   ,fileExtension
   ,replaceExtension
+  ,splitDrive
+  ,takeDrive
+  ,dropDrive
+  ,isDrive
   ,mapSomeBase
   ,prjSomeBase
    -- * Parsing
@@ -377,6 +381,31 @@
     $ FilePath.takeDirectory
     $ FilePath.dropTrailingPathSeparator fp
 
+-- | 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) = FilePath.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
+
 -- | Extract the file part of a path.
 --
 -- The following properties hold:
@@ -454,8 +483,8 @@
             xtn  = (takeWhile notSep . dropWhile isSep) rstr
         in (reverse name, reverse xtn ++ trailingSeps)
     normalizeDrive
         | IS_WINDOWS = normalizeTrailingSeps
         | otherwise  = id
 
     (drv, pth)     = FilePath.splitDrive fpath
     (dir, file)    = splitLast FilePath.isPathSeparator pth
@@ -818,8 +847,8 @@
 -- | Applies platform-specific sep normalization following @FilePath.normalise@.
 normalizeFilePath :: FilePath -> FilePath
 normalizeFilePath
   | IS_WINDOWS = normalizeWindowsSeps . FilePath.normalise
   | otherwise  = normalizeLeadingSeps . FilePath.normalise
 
 -- | Path of some type.  @t@ represents the type, whether file or
 -- directory.  Pattern match to find whether the path is absolute or

stack.yaml

@@ -1,45 +1 @@
-resolver: nightly-2021-11-19
-extra-deps:
-- github: NorfairKing/validity
-  commit: 35bc8d45b27e6c21429e4b681b16e46ccd541b3b
-  subdirs:
-    - genvalidity
-    - genvalidity-aeson
-    - genvalidity-bytestring
-    - genvalidity-containers
-    - genvalidity-criterion
-    - genvalidity-hspec
-    - genvalidity-hspec-aeson
-    - genvalidity-hspec-binary
-    - genvalidity-hspec-cereal
-    - genvalidity-hspec-hashable
-    - genvalidity-hspec-optics
-    - genvalidity-hspec-persistent
-    - genvalidity-path
-    - genvalidity-persistent
-    - genvalidity-property
-    - genvalidity-scientific
-    - genvalidity-sydtest
-    - genvalidity-sydtest-aeson
-    - genvalidity-sydtest-hashable
-    - genvalidity-sydtest-lens
-    - genvalidity-sydtest-persistent
-    - genvalidity-text
-    - genvalidity-time
-    - genvalidity-unordered-containers
-    - genvalidity-uuid
-    - genvalidity-vector
-    - validity
-    - validity-aeson
-    - validity-bytestring
-    - validity-containers
-    - validity-path
-    - validity-persistent
-    - validity-primitive
-    - validity-scientific
-    - validity-text
-    - validity-time
-    - validity-unordered-containers
-    - validity-uuid
-    - validity-vector
-
+resolver: nightly-2023-10-16 # GHC 9.6.3