Skip to content

Commit

Permalink
Implement AbstractFilePath
Browse files Browse the repository at this point in the history
  • Loading branch information
@hasufell
hasufell committed Mar 22, 2022
1 parent 4638d2a commit 213e6cd
Show file tree
Hide file tree
Showing 36 changed files with 5,249 additions and 2,446 deletions.
112 changes: 81 additions & 31 deletions .github/workflows/test.yaml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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-deb10-linux.tar.xz?job=validate-x86_64-linux-deb10-hadrian' head
ghcup set ghc head
ghcup install ghc -u 'https://gitlab.haskell.org/api/v4/projects/1/jobs/artifacts/master/raw/ghc-x86_64-deb10-linux.tar.xz?job=validate-x86_64-linux-deb10-unreg-hadrian' --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
Expand Down Expand Up @@ -102,33 +102,83 @@ jobs:
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 cpphs git make curl
run: |
curl -O https://hackage.haskell.org/package/bytestring-0.11.3.0/bytestring-0.11.3.0.tar.gz
tar xf bytestring-0.11.3.0.tar.gz
rm bytestring-0.11.3.0.tar.gz
cd bytestring-0.11.3.0
find . -type f -not -path './Data/ByteString/Short.hs' -a -not -path './Data/ByteString/Internal.hs' -a -not -path './Data/ByteString/Short/Internal.hs' -a -not -path './cbits/*' -a -not -path './include/*' -delete
cd cbits/
gcc -c -I../include -I/usr/lib/ghc/include/ -std=c11 -fPIC -DNDEBUG=1 *.c
gcc -shared -o libshortbytestring.so *.o
mv libshortbytestring.so /usr/lib/
cd ../../
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/ -ibytestring-0.11.3.0/ -L./bytestring-0.11.3.0/cbits/ -lshortbytestring +RTS -s
./Main +RTS -s
ghc --make -o Main tests/Main.hs -DGHC_MAKE -itests/ -ibytestring-0.11.3.0/ -L./bytestring-0.11.3.0/cbits/ -lshortbytestring +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 cpphs git make curl libghc-exceptions-dev
shell: bash
- uses: actions/checkout@v1
- name: test
run: |
curl -O https://hackage.haskell.org/package/bytestring-0.11.3.0/bytestring-0.11.3.0.tar.gz
tar xf bytestring-0.11.3.0.tar.gz
rm bytestring-0.11.3.0.tar.gz
cd bytestring-0.11.3.0
find . -type f -not -path './Data/ByteString/Short.hs' -a -not -path './Data/ByteString/Internal.hs' -a -not -path './Data/ByteString/Short/Internal.hs' -a -not -path './cbits/*' -a -not -path './include/*' -delete
cd cbits/
gcc -c -I../include -I/usr/lib/ghc/include/ -std=c11 -fPIC -DNDEBUG=1 *.c
gcc -shared -o libshortbytestring.so *.o
mv libshortbytestring.so /usr/lib/
cd ../../
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/ -ibytestring-0.11.3.0/ -L./bytestring-0.11.3.0/cbits/ -lshortbytestring +RTS -s
./Main +RTS -s
ghc --make -o Main tests/Main.hs -DGHC_MAKE -itests/ -ibytestring-0.11.3.0/ -L./bytestring-0.11.3.0/cbits/ -lshortbytestring +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: |
cabal update
cabal sdist
tar xf dist-newstyle/sdist/filepath-*.tar.gz
cd filepath-*
cabal build
98 changes: 86 additions & 12 deletions Generate.hs
View file
Original file line number Diff line number Diff line change
@@ -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
Expand All @@ -16,19 +17,36 @@ 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 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 | W | AFP_P | AFP_W deriving Show -- Posix or Windows
data Test = Test
{testPlatform :: PW
,testVars :: [(String,String)] -- generator constructor, variable
Expand All @@ -39,19 +57,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 _ = []


Expand Down Expand Up @@ -80,14 +101,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



---------------------------------------------------------------------
Expand Down
9 changes: 3 additions & 6 deletions Makefile
View file
Original file line number Diff line number Diff line change
@@ -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
Loading

0 comments on commit 213e6cd

Please sign in to comment.