#49, document the specific case requested in the ticket
[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 ,"tests :: [(String, Test)]"
24 ,"tests ="] ++
25 [" " ++ c ++ "(" ++ show t1 ++ ", " ++ t2 ++ ")" | (c,(t1,t2)) <- zip ("[":repeat ",") tests] ++
26 [" ]"]
27
28
29
30 data PW = P | W deriving Show -- Posix or Windows
31 data Test = Test
32 {testPlatform :: PW
33 ,testVars :: [(String,String)] -- generator constructor, variable
34 ,testBody :: [String]
35 }
36
37
38 parseTest :: String -> [Test]
39 parseTest (stripPrefix "-- > " -> Just x) = platform $ toLexemes x
40 where
41 platform ("Windows":":":x) = [valid W x]
42 platform ("Posix" :":":x) = [valid P x]
43 platform x = [valid P x, valid W x]
44
45 valid p ("Valid":x) = free p a $ drop 1 b
46 where (a,b) = break (== "=>") x
47 valid p x = free p [] x
48
49 free p val x = Test p [(ctor v, v) | v <- vars] x
50 where vars = nub $ sort [v | v@[c] <- x, isAlpha c]
51 ctor v = if v < "x" then "" else if v `elem` val then "QFilePathValid" ++ show p else "QFilePath"
52 parseTest _ = []
53
54
55 toLexemes :: String -> [String]
56 toLexemes x = case lex x of
57 [("","")] -> []
58 [(x,y)] -> x : toLexemes y
59 y -> error $ "Generate.toLexemes, " ++ show x ++ " -> " ++ show y
60
61
62 fromLexemes :: [String] -> String
63 fromLexemes = unwords . f
64 where
65 f ("`":x:"`":xs) = ("`" ++ x ++ "`") : f xs
66 f (x:y:xs) | x `elem` ["[","("] || y `elem` [",",")","]"] = f $ (x ++ y) : xs
67 f (x:xs) = x : f xs
68 f [] = []
69
70
71 renderTest :: Test -> (String, String)
72 renderTest Test{..} = (body, code)
73 where
74 code = "test $ " ++ if null testVars then body else "\\" ++ unwords vars ++ " -> " ++ body
75 vars = [if null ctor then v else "(" ++ ctor ++ " " ++ v ++ ")" | (ctor,v) <- testVars]
76
77 body = fromLexemes $ map (qualify testPlatform) testBody
78
79
80 qualify :: PW -> String -> String
81 qualify pw str
82 | str `elem` fpops || (all isAlpha str && length str > 1 && not (str `elem` prelude)) = show pw ++ "." ++ str
83 | otherwise = str
84 where
85 prelude = ["elem","uncurry","snd","fst","not","null","if","then","else"
86 ,"True","False","concat","isPrefixOf","isSuffixOf","any"]
87 fpops = ["</>","<.>","-<.>"]
88
89
90 ---------------------------------------------------------------------
91 -- UTILITIES
92
93 writeFileBinary :: FilePath -> String -> IO ()
94 writeFileBinary file x = withBinaryFile file WriteMode $ \h -> hPutStr h x
95
96 readFileBinary' :: FilePath -> IO String
97 readFileBinary' file = withBinaryFile file ReadMode $ \h -> do
98 s <- hGetContents h
99 evaluate $ length s
100 return s
101
102 writeFileBinaryChanged :: FilePath -> String -> IO ()
103 writeFileBinaryChanged file x = do
104 b <- doesFileExist file
105 old <- if b then fmap Just $ readFileBinary' file else return Nothing
106 when (Just x /= old) $
107 writeFileBinary file x