1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
|
{-# 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
import System.IO
main :: IO ()
main = do
src <- readFile "System/FilePath/Internal.hs"
let tests = map renderTest $ concatMap parseTest $ lines src
writeFileBinaryChanged "tests/filepath-tests/TestGen.hs" $ unlines $
["-- GENERATED CODE: See ../Generate.hs"
#ifndef GHC_MAKE
, "{-# LANGUAGE OverloadedStrings #-}"
, "{-# LANGUAGE ViewPatterns #-}"
#endif
, "{-# LANGUAGE CPP #-}"
, "{-# OPTIONS_GHC -Wno-name-shadowing #-}"
, "{-# OPTIONS_GHC -Wno-orphans #-}"
,"module TestGen(tests) where"
,"import TestUtil"
,"#if !MIN_VERSION_base(4,11,0)"
,"import Data.Semigroup"
,"#endif"
,"import Prelude as P"
,"import Data.String"
,"import GHC.IO.Encoding.Failure ( CodingFailureMode(..) )"
,"import GHC.IO.Encoding.UTF16 ( mkUTF16le )"
,"import GHC.IO.Encoding.UTF8 ( mkUTF8 )"
,"import System.OsString.Internal.Types"
,"import System.OsString.Encoding.Internal"
,"import qualified Data.Char as C"
,"import qualified System.OsString.Data.ByteString.Short as SBS"
,"import qualified System.OsString.Data.ByteString.Short.Word16 as SBS16"
,"import qualified System.FilePath.Windows as W"
,"import qualified System.FilePath.Posix as P"
#ifdef GHC_MAKE
,"import qualified System.OsPath.Windows.Internal as AFP_W"
,"import qualified System.OsPath.Posix.Internal as AFP_P"
#else
,"import qualified System.OsPath.Windows as AFP_W"
,"import qualified System.OsPath.Posix as AFP_P"
#endif
,"instance IsString WindowsString where fromString = WS . either (error . show) id . encodeWithTE (mkUTF16le TransliterateCodingFailure)"
,"instance IsString PosixString where fromString = PS . either (error . show) id . encodeWithTE (mkUTF8 TransliterateCodingFailure)"
,"#if defined(mingw32_HOST_OS) || defined(__MINGW32__)"
,"instance IsString OsString where fromString = OsString . WS . either (error . show) id . encodeWithTE (mkUTF16le TransliterateCodingFailure)"
,"#else"
,"instance IsString OsString where fromString = OsString . PS . either (error . show) id . encodeWithTE (mkUTF8 TransliterateCodingFailure)"
,"#endif"
,"tests :: [(String, Property)]"
,"tests ="] ++
[" " ++ c ++ "(" ++ show t1 ++ ", " ++ t2 ++ ")" | (c,(t1,t2)) <- zip ("[":repeat ",") tests] ++
[" ]"]
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
,testBody :: [String]
}
parseTest :: String -> [Test]
parseTest (stripPrefix "-- > " -> Just x) = platform $ toLexemes x
where
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" = ""
| v `elem` val = "QFilePathValid" ++ show p
| 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 _ = []
toLexemes :: String -> [String]
toLexemes x = case lex x of
[("","")] -> []
[(x,y)] -> x : toLexemes y
y -> error $ "Generate.toLexemes, " ++ show x ++ " -> " ++ show y
fromLexemes :: [String] -> String
fromLexemes = unwords . f
where
f ("`":x:"`":xs) = ("`" ++ x ++ "`") : f xs
f (x:y:xs) | x `elem` ["[","("] || y `elem` [",",")","]"] = f $ (x ++ y) : xs
f (x:xs) = x : f xs
f [] = []
renderTest :: Test -> (String, String)
renderTest Test{..} = (body, code)
where
code = "property $ " ++ if null testVars then body else "\\" ++ unwords vars ++ " -> " ++ body
vars = [if null ctor then v else "(" ++ ctor ++ " " ++ v ++ ")" | (ctor,v) <- testVars]
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)
= if str `elem` bs then qualifyBS str else show pw ++ "." ++ str
| otherwise = encode str
where
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 getPosixString)"
| v == "any" -> "(\\f (getPosixString -> x) -> SBS." <> v <> " (f . PW) x)"
| v == "isPrefixOf" -> "(\\(getPosixString -> x) (getPosixString -> y) -> SBS." <> v <> " x y)"
| v == "isSuffixOf" -> "(\\(getPosixString -> x) (getPosixString -> y) -> SBS." <> v <> " x y)"
| otherwise -> "(SBS." <> v <> " . getPosixString)"
AFP_W
| v == "concat" -> "(WS . SBS16." <> v <> " . fmap getWindowsString)"
| v == "any" -> "(\\f (getWindowsString -> x) -> SBS16." <> v <> " (f . WW) x)"
| v == "isPrefixOf" -> "(\\(getWindowsString -> x) (getWindowsString -> y) -> SBS16." <> v <> " x y)"
| v == "isSuffixOf" -> "(\\(getWindowsString -> x) (getWindowsString -> y) -> SBS16." <> v <> " x y)"
| otherwise -> "(SBS16." <> v <> " . getWindowsString)"
_ -> v
#endif
---------------------------------------------------------------------
-- UTILITIES
writeFileBinary :: FilePath -> String -> IO ()
writeFileBinary file x = withBinaryFile file WriteMode $ \h -> hPutStr h x
readFileBinary' :: FilePath -> IO String
readFileBinary' file = withBinaryFile file ReadMode $ \h -> do
s <- hGetContents h
evaluate $ length s
pure s
writeFileBinaryChanged :: FilePath -> String -> IO ()
writeFileBinaryChanged file x = do
b <- doesFileExist file
old <- if b then fmap Just $ readFileBinary' file else pure Nothing
when (Just x /= old) $
writeFileBinary file x
|
