Merge branch 'AFPP'

.github/workflows/test.yaml

@@ -14,43 +14,45 @@ jobs:
       fail-fast: false
       matrix:
         os: [ubuntu-latest, macOS-latest, windows-latest]
-        ghc: ['8.0.2', '8.2.2', '8.4.4', '8.6.5', '8.8.4', '8.10.7', '9.0.2', '9.2.1']
-        cabal: ['3.6.2.0']
+        ghc: ['8.0', '8.2', '8.4', '8.6', '8.8', '8.10', '9.0', '9.2']
+        cabal: ['latest']
         include:
-          - os: ubuntu-latest
-            ghc: 'HEAD'
-            experimental: true
           - os: ubuntu-latest
             ghc: 'recommended'
             experimental: true
           - os: ubuntu-latest
             ghc: 'latest'
             experimental: true
+          - os: windows-latest
+            ghc: '9.2.1'
+            experimental: true
         exclude:
           - os: macOS-latest
-            ghc: '8.0.2'
+            ghc: '8.0'
           - os: macOS-latest
-            ghc: '8.2.2'
+            ghc: '8.2'
           - os: macOS-latest
-            ghc: '8.4.4'
+            ghc: '8.4'
           - os: macOS-latest
-            ghc: '8.6.5'
+            ghc: '8.6'
           - os: macOS-latest
-            ghc: '8.8.4'
+            ghc: '8.8'
           - os: macOS-latest
-            ghc: '9.0.2'
+            ghc: '9.0'
+          - os: windows-latest
+            ghc: '8.0'
           - os: windows-latest
-            ghc: '8.0.2'
+            ghc: '8.2'
           - os: windows-latest
-            ghc: '8.2.2'
+            ghc: '8.4'
           - os: windows-latest
-            ghc: '8.4.4'
+            ghc: '8.6'
           - os: windows-latest
-            ghc: '8.6.5'
+            ghc: '8.8'
           - os: windows-latest
-            ghc: '8.8.4'
+            ghc: '9.0'
           - os: windows-latest
-            ghc: '9.0.2'
+            ghc: '9.2'
 
     steps:
     - uses: actions/checkout@v2
@@ -59,22 +61,20 @@ jobs:
       run: |
         set -eux
         if [ "${{ matrix.ghc }}" == 'HEAD' ] ; then
-          ghcup install ghc -u 'https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-linux-deb10-unreg-validate.tar.xz?job=x86_64-linux-deb10-unreg-validate' head
-          ghcup set ghc head
+          ghcup install ghc -u 'https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-linux-deb10-unreg-validate.tar.xz?job=x86_64-linux-deb10-unreg-validate' --set head
         else
-          ghcup install ghc ${{ matrix.ghc }}
-          ghcup set ghc ${{ matrix.ghc }}
+          ghcup install ghc --set ${{ matrix.ghc }}
         fi
         ghcup install cabal ${{ matrix.cabal }}
       shell: bash
 
     - name: Build
       run: |
         set -eux
-        [ "${{ matrix.ghc }}" == 'HEAD' ] ||
-          [ "${{ matrix.ghc }}" == 'recommended' ] ||
-          [ "${{ matrix.ghc }}" == 'latest' ] ||
-          [ "$(ghc --numeric-version)" = "${{ matrix.ghc }}" ] 
+        [[ "${{ matrix.ghc }}" == 'HEAD' ]] ||
+          [[ "${{ matrix.ghc }}" == 'recommended' ]] ||
+          [[ "${{ matrix.ghc }}" == 'latest' ]] ||
+          [[ "$(ghc --numeric-version)" =~ "${{ matrix.ghc }}" ]]
         cabal update
         cabal build --enable-tests --enable-benchmarks
         cabal test
@@ -88,7 +88,6 @@ jobs:
       run: |
         set -eux
         export "PATH=$HOME/.cabal/bin:$PATH"
-        cabal install --overwrite-policy=always --install-method=copy cpphs
         make all
         git diff --exit-code
 
@@ -98,37 +97,70 @@ jobs:
     strategy:
       fail-fast: true
       matrix:
-        arch: ['s390x', 'ppc64le', 'armv7', 'aarch64']
+        # arch: ['s390x', 'ppc64le', 'armv7', 'aarch64']
+        arch: ['ppc64le', 'armv7', 'aarch64']
     steps:
     - uses: actions/checkout@v2
     - uses: uraimo/run-on-arch-action@v2.1.1
-      timeout-minutes: 60
+      timeout-minutes: 180
       with:
         arch: ${{ matrix.arch }}
         distro: ubuntu20.04
         githubToken: ${{ github.token }}
         install: |
           apt-get update -y
-          apt-get install -y ghc libghc-quickcheck2-dev cpphs git make
+          apt-get install -y ghc libghc-quickcheck2-dev libghc-tasty-dev libghc-tasty-quickcheck-dev git make curl
         run: |
           ghc --version
-          ghc --make -o Main tests/Test.hs -itests/ +RTS -s
+          runhaskell --ghc-arg=-DGHC_MAKE Generate.hs
+          ghc --make -o Main tests/Test.hs -DGHC_MAKE -itests/ -O0 +RTS -s
+          ./Main 100 500 +RTS -s
+          ./Main 100 -500 +RTS -s
+          ghc --make -o Main tests/Main.hs -DGHC_MAKE -itests/ -O0 +RTS -s
           ./Main +RTS -s
 
   emulated-i386:
     runs-on: ubuntu-latest
     container:
-      image: i386/ubuntu:bionic
+      image: i386/debian:sid
     steps:
     - name: install
       run: |
           apt-get update -y
-          apt-get install -y ghc libghc-quickcheck2-dev cpphs git make
+          apt-get install -y ghc libghc-quickcheck2-dev libghc-tasty-dev libghc-tasty-quickcheck-dev git make curl libghc-exceptions-dev
       shell: bash
     - uses: actions/checkout@v1
     - name: test
       run: |
           ghc --version
-          ghc --make -o Main tests/Test.hs -itests/ +RTS -s
+          runhaskell --ghc-arg=-DGHC_MAKE Generate.hs
+          ghc --make -o Main tests/Test.hs -DGHC_MAKE -itests/ +RTS -s
+          ./Main +RTS -s
+          ghc --make -o Main tests/Main.hs -DGHC_MAKE -itests/ +RTS -s
           ./Main +RTS -s
       shell: bash
+
+  bounds-checking:
+    needs: build
+    runs-on: ubuntu-latest
+    steps:
+    - uses: actions/checkout@v2
+    - name: Test
+      run: |
+        ghcup install ghc --set 9.2.2
+        ghcup install cabal latest
+        cabal update
+        cabal run -w ghc-9.2.2 --ghc-options='-fcheck-prim-bounds -fno-ignore-asserts' bytestring-tests
+
+  sdist:
+    runs-on: ubuntu-latest
+    steps:
+    - uses: actions/checkout@v2
+    - name: Test
+      run: |
+        rm cabal.project
+        cabal update
+        cabal sdist
+        tar xf dist-newstyle/sdist/filepath-*.tar.gz
+        cd filepath-*
+        cabal build

Generate.hs

@@ -1,9 +1,10 @@
-{-# LANGUAGE RecordWildCards, ViewPatterns #-}
+{-# LANGUAGE CPP, RecordWildCards, ViewPatterns #-}
 
 module Generate(main) where
 
 import Control.Exception
 import Control.Monad
+import Data.Semigroup
 import Data.Char
 import Data.List
 import System.Directory
@@ -16,19 +17,41 @@ main = do
     let tests = map renderTest $ concatMap parseTest $ lines src
     writeFileBinaryChanged "tests/TestGen.hs" $ unlines $
         ["-- GENERATED CODE: See ../Generate.hs"
+#ifndef GHC_MAKE
+        , "{-# LANGUAGE OverloadedStrings #-}"
+        , "{-# LANGUAGE ViewPatterns #-}"
+#endif
         ,"module TestGen(tests) where"
         ,"import TestUtil"
+        ,"import Prelude as P"
+        ,"import Data.Semigroup"
+        ,"import qualified Data.Char as C"
+        ,"import qualified System.AbstractFilePath.Data.ByteString.Short as SBS"
+        ,"import qualified System.AbstractFilePath.Data.ByteString.Short.Word16 as SBS16"
         ,"import qualified System.FilePath.Windows as W"
         ,"import qualified System.FilePath.Posix as P"
-        ,"{-# ANN module \"HLint: ignore\" #-}"
+#ifdef GHC_MAKE
+        ,"import qualified System.AbstractFilePath.Windows.Internal as AFP_W"
+        ,"import qualified System.AbstractFilePath.Posix.Internal as AFP_P"
+#else
+        ,"import System.AbstractFilePath.Types"
+        ,"import qualified System.AbstractFilePath.Windows as AFP_W"
+        ,"import qualified System.AbstractFilePath.Posix as AFP_P"
+#endif
+        , "import System.AbstractFilePath.Data.ByteString.Short.Encode"
         ,"tests :: [(String, Property)]"
         ,"tests ="] ++
         ["    " ++ c ++ "(" ++ show t1 ++ ", " ++ t2 ++ ")" | (c,(t1,t2)) <- zip ("[":repeat ",") tests] ++
         ["    ]"]
 
 
 
-data PW = P | W deriving Show -- Posix or Windows
+data PW = P      -- legacy posix
+        | W      -- legacy windows
+        | AFP_P  -- abstract-filepath posix
+        | AFP_W  -- abstract-filepath windows
+  deriving Show
+
 data Test = Test
     {testPlatform :: PW
     ,testVars :: [(String,String)]   -- generator constructor, variable
@@ -39,19 +62,22 @@ data Test = Test
 parseTest :: String -> [Test]
 parseTest (stripPrefix "-- > " -> Just x) = platform $ toLexemes x
     where
-        platform ("Windows":":":x) = [valid W x]
-        platform ("Posix"  :":":x) = [valid P x]
-        platform x                 = [valid P x, valid W x]
+        platform ("Windows":":":x) = [valid W x, valid AFP_W x]
+        platform ("Posix"  :":":x) = [valid P x, valid AFP_P x]
+        platform x                 = [valid P x, valid W x, valid AFP_P x, valid AFP_W x]
 
         valid p ("Valid":x) = free p a $ drop 1 b
             where (a,b) = break (== "=>") x
         valid p x = free p [] x
 
         free p val x = Test p [(ctor v, v) | v <- vars] x
             where vars = nub $ sort [v | v@[c] <- x, isAlpha c]
-                  ctor v | v < "x" = ""
+                  ctor v | v < "x"  = ""
                          | v `elem` val = "QFilePathValid" ++ show p
-                         | otherwise = "QFilePath"
+                         | otherwise = case p of
+                                         AFP_P -> if v == "z" then "QFilePathsAFP_P" else "QFilePathAFP_P"
+                                         AFP_W -> if v == "z" then "QFilePathsAFP_W" else "QFilePathAFP_W"
+                                         _ -> if v == "z" then "" else "QFilePath"
 parseTest _ = []
 
 
@@ -80,14 +106,67 @@ renderTest Test{..} = (body, code)
         body = fromLexemes $ map (qualify testPlatform) testBody
 
 
+
 qualify :: PW -> String -> String
 qualify pw str
-    | str `elem` fpops || (all isAlpha str && length str > 1 && str `notElem` prelude) = show pw ++ "." ++ str
-    | otherwise = str
+    | str `elem` fpops || (all isAlpha str && length str > 1 && str `notElem` prelude)
+      = if str `elem` bs then qualifyBS str  else show pw ++ "." ++ str
+    | otherwise = encode str
     where
-        prelude = ["elem","uncurry","snd","fst","not","null","if","then","else"
-                  ,"True","False","Just","Nothing","fromJust","concat","isPrefixOf","isSuffixOf","any","foldr"]
+        bs = ["null", "concat", "isPrefixOf", "isSuffixOf", "any"]
+        prelude = ["elem","uncurry","snd","fst","not","if","then","else"
+                  ,"True","False","Just","Nothing","fromJust","foldr"]
         fpops = ["</>","<.>","-<.>"]
+#ifdef GHC_MAKE
+        encode v
+          | isString' v = case pw of
+                            AFP_P -> "(encodeUtf8 " <> v <> ")"
+                            AFP_W -> "(encodeUtf16LE " <> v <> ")"
+                            _ -> v
+          | isChar' v = case pw of
+                            AFP_P -> "(fromIntegral . C.ord $ " <> v <> ")"
+                            AFP_W -> "(fromIntegral . C.ord $ " <> v <> ")"
+                            _ -> v
+          | otherwise = v
+        isString' xs@('"':_:_) = last xs == '"'
+        isString' _ = False
+        isChar' xs@('\'':_:_) = last xs == '\''
+        isChar' _ = False
+        qualifyBS v = case pw of
+                        AFP_P -> "SBS." <> v
+                        AFP_W -> "SBS16." <> v
+                        _ -> v
+#else
+        encode v
+          | isString' v = case pw of
+                            AFP_P -> "(" <> v <> ")"
+                            AFP_W -> "(" <> v <> ")"
+                            _ -> v
+          | isChar' v = case pw of
+                            AFP_P -> "(PW . fromIntegral . C.ord $ " <> v <> ")"
+                            AFP_W -> "(WW . fromIntegral . C.ord $ " <> v <> ")"
+                            _ -> v
+          | otherwise = v
+        isString' xs@('"':_:_) = last xs == '"'
+        isString' _ = False
+        isChar' xs@('\'':_:_) = last xs == '\''
+        isChar' _ = False
+        qualifyBS v = case pw of
+                        AFP_P
+                          | v == "concat" -> "(PS . SBS." <> v <> " . fmap unPFP)"
+                          | v == "any" -> "(\\f (unPFP -> x) -> SBS." <> v <> " (f . PW) x)"
+                          | v == "isPrefixOf" -> "(\\(unPFP -> x) (unPFP -> y) -> SBS." <> v <> " x y)"
+                          | v == "isSuffixOf" -> "(\\(unPFP -> x) (unPFP -> y) -> SBS." <> v <> " x y)"
+                          | otherwise -> "(SBS." <> v <> " . unPFP)"
+                        AFP_W
+                          | v == "concat" -> "(WS . SBS16." <> v <> " . fmap unWFP)"
+                          | v == "any" -> "(\\f (unWFP -> x) -> SBS16." <> v <> " (f . WW) x)"
+                          | v == "isPrefixOf" -> "(\\(unWFP -> x) (unWFP -> y) -> SBS16." <> v <> " x y)"
+                          | v == "isSuffixOf" -> "(\\(unWFP -> x) (unWFP -> y) -> SBS16." <> v <> " x y)"
+                          | otherwise -> "(SBS16." <> v <> " . unWFP)"
+                        _ -> v
+#endif
+
 
 
 ---------------------------------------------------------------------

Makefile

@@ -1,10 +1,7 @@
-all: cpp gen
-
-cpp:
-	cpphs --noline -DIS_WINDOWS=False -DMODULE_NAME=Posix   -OSystem/FilePath/Posix.hs   System/FilePath/Internal.hs
-	cpphs --noline -DIS_WINDOWS=True  -DMODULE_NAME=Windows -OSystem/FilePath/Windows.hs System/FilePath/Internal.hs
+all: gen
 
 gen:
 	runhaskell Generate.hs
 
-.PHONY: all cpp gen
+
+.PHONY: all gen

README.md

@@ -14,19 +14,21 @@ All three modules provide the same API, and the same documentation (calling out
 
 ### What is a `FilePath`?
 
-In Haskell, the definition is `type FilePath = String` as of now. A Haskell `String` is a list of Unicode code points.
+In Haskell, the legacy definition (used in `base` and Prelude) is `type FilePath = String`,
+where a Haskell `String` is a list of Unicode code points.
+
+The new definition is (simplified) `newtype AbstractFilePath = AFP ShortByteString`, where
+`ShortByteString` is an unpinned byte array and follows syscall conventions, preserving the encoding.
 
 On unix, filenames don't have a predefined encoding as per the
 [POSIX specification](https://pubs.opengroup.org/onlinepubs/9699919799/basedefs/V1_chap03.html#tag_03_170)
 and are passed as `char[]` to syscalls.
 
 On windows (at least the API used by `Win32`) filepaths are UTF-16 strings.
 
-This means that Haskell filepaths have to be converted to C-strings on unix
-(utilizing the current filesystem encoding) and to UTF-16 strings
-on windows.
+You are encouraged to use `AbstractFilePath` whenever possible, because it is more correct.
 
-Further, this is a low-level library and it makes no attempt at providing a more
+Also note that this is a low-level library and it makes no attempt at providing a more
 type safe variant for filepaths (e.g. by distinguishing between absolute and relative
 paths) and ensures no invariants (such as filepath validity).