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
|
{-# LANGUAGE RecordWildCards, ViewPatterns #-}
module Generate(main) where
import Control.Exception
import Control.Monad
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/TestGen.hs" $ unlines $
["-- GENERATED CODE: See ../Generate.hs"
,"module TestGen(tests) where"
,"import TestUtil"
,"import qualified System.FilePath.Windows as W"
,"import qualified System.FilePath.Posix as P"
,"{-# ANN module \"HLint: ignore\" #-}"
,"tests :: [(String, Property)]"
,"tests ="] ++
[" " ++ c ++ "(" ++ show t1 ++ ", " ++ t2 ++ ")" | (c,(t1,t2)) <- zip ("[":repeat ",") tests] ++
[" ]"]
data PW = P | W deriving Show -- Posix or Windows
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]
platform ("Posix" :":":x) = [valid P x]
platform x = [valid P x, valid 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 = "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) = show pw ++ "." ++ str
| otherwise = str
where
prelude = ["elem","uncurry","snd","fst","not","null","if","then","else"
,"True","False","Just","Nothing","fromJust","concat","isPrefixOf","isSuffixOf","any"]
fpops = ["</>","<.>","-<.>"]
---------------------------------------------------------------------
-- 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
|
