Add developer notes
[packages/filepath.git] / Generate.hs
1 {-# LANGUAGE RecordWildCards, ViewPatterns #-}
2
3 module Generate(main) where
4
5 import Control.Exception
6 import Control.Monad
7 import Data.Char
8 import Data.List
9 import System.Directory
10 import System.IO
11
12
13 main :: IO ()
14 main = do
15 src <- readFile "System/FilePath/Internal.hs"
16 let tests = map renderTest $ concatMap parseTest $ lines src
17 writeFileBinaryChanged "tests/TestGen.hs" $ unlines $
18 ["-- GENERATED CODE: See ../Generate.hs"
19 ,"module TestGen(tests) where"
20 ,"import TestUtil"
21 ,"import qualified System.FilePath.Windows as W"
22 ,"import qualified System.FilePath.Posix as P"
23 ,"{-# ANN module \"HLint: ignore\" #-}"
24 ,"tests :: [(String, Property)]"
25 ,"tests ="] ++
26 [" " ++ c ++ "(" ++ show t1 ++ ", " ++ t2 ++ ")" | (c,(t1,t2)) <- zip ("[":repeat ",") tests] ++
27 [" ]"]
28
29
30
31 data PW = P | W deriving Show -- Posix or Windows
32 data Test = Test
33 {testPlatform :: PW
34 ,testVars :: [(String,String)] -- generator constructor, variable
35 ,testBody :: [String]
36 }
37
38
39 parseTest :: String -> [Test]
40 parseTest (stripPrefix "-- > " -> Just x) = platform $ toLexemes x
41 where
42 platform ("Windows":":":x) = [valid W x]
43 platform ("Posix" :":":x) = [valid P x]
44 platform x = [valid P x, valid W x]
45
46 valid p ("Valid":x) = free p a $ drop 1 b
47 where (a,b) = break (== "=>") x
48 valid p x = free p [] x
49
50 free p val x = Test p [(ctor v, v) | v <- vars] x
51 where vars = nub $ sort [v | v@[c] <- x, isAlpha c]
52 ctor v | v < "x" = ""
53 | v `elem` val = "QFilePathValid" ++ show p
54 | otherwise = "QFilePath"
55 parseTest _ = []
56
57
58 toLexemes :: String -> [String]
59 toLexemes x = case lex x of
60 [("","")] -> []
61 [(x,y)] -> x : toLexemes y
62 y -> error $ "Generate.toLexemes, " ++ show x ++ " -> " ++ show y
63
64
65 fromLexemes :: [String] -> String
66 fromLexemes = unwords . f
67 where
68 f ("`":x:"`":xs) = ("`" ++ x ++ "`") : f xs
69 f (x:y:xs) | x `elem` ["[","("] || y `elem` [",",")","]"] = f $ (x ++ y) : xs
70 f (x:xs) = x : f xs
71 f [] = []
72
73
74 renderTest :: Test -> (String, String)
75 renderTest Test{..} = (body, code)
76 where
77 code = "property $ " ++ if null testVars then body else "\\" ++ unwords vars ++ " -> " ++ body
78 vars = [if null ctor then v else "(" ++ ctor ++ " " ++ v ++ ")" | (ctor,v) <- testVars]
79
80 body = fromLexemes $ map (qualify testPlatform) testBody
81
82
83 qualify :: PW -> String -> String
84 qualify pw str
85 | str `elem` fpops || (all isAlpha str && length str > 1 && str `notElem` prelude) = show pw ++ "." ++ str
86 | otherwise = str
87 where
88 prelude = ["elem","uncurry","snd","fst","not","null","if","then","else"
89 ,"True","False","Just","Nothing","fromJust","concat","isPrefixOf","isSuffixOf","any"]
90 fpops = ["</>","<.>","-<.>"]
91
92
93 ---------------------------------------------------------------------
94 -- UTILITIES
95
96 writeFileBinary :: FilePath -> String -> IO ()
97 writeFileBinary file x = withBinaryFile file WriteMode $ \h -> hPutStr h x
98
99 readFileBinary' :: FilePath -> IO String
100 readFileBinary' file = withBinaryFile file ReadMode $ \h -> do
101 s <- hGetContents h
102 evaluate $ length s
103 return s
104
105 writeFileBinaryChanged :: FilePath -> String -> IO ()
106 writeFileBinaryChanged file x = do
107 b <- doesFileExist file
108 old <- if b then fmap Just $ readFileBinary' file else return Nothing
109 when (Just x /= old) $
110 writeFileBinary file x