|
1 {-# LANGUAGE FlexibleContexts #-} |
|
2 |
|
3 module Main where |
|
4 |
|
5 import System.Directory |
|
6 import Control.Monad |
|
7 import Data.List |
|
8 import Text.Parsec |
|
9 import Control.Monad.IO.Class |
|
10 import Data.Maybe |
|
11 |
|
12 data LuaCode = |
|
13 Comments String |
|
14 | LuaLocString LuaCode LuaCode |
|
15 | LuaString String LuaCode |
|
16 | CodeChunk String LuaCode |
|
17 | LuaOp String LuaCode |
|
18 | BlocksList Char [LuaCode] |
|
19 | NoCode |
|
20 deriving (Show, Eq) |
|
21 |
|
22 toChunk a = CodeChunk a NoCode |
|
23 |
|
24 isLuaString LuaLocString{} = True |
|
25 isLuaString LuaString{} = True |
|
26 isLuaString _ = False |
|
27 |
|
28 isLocString (BlocksList _ blocks) = or $ map isLocString blocks |
|
29 isLocString LuaLocString{} = True |
|
30 isLocString (LuaString _ lc) = isLocString lc |
|
31 isLocString (CodeChunk _ lc) = isLocString lc |
|
32 isLocString (LuaOp _ lc) = isLocString lc |
|
33 isLocString _ = False |
|
34 |
|
35 many1Till :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a] |
|
36 many1Till p end = do |
|
37 res <- scan |
|
38 if null res then unexpected "many1Till" else return res |
|
39 where |
|
40 scan = do{ end; return [] } |
|
41 <|> |
|
42 do{ x <- p; xs <- scan; return (x:xs) } |
|
43 |
|
44 processScript :: String -> IO [LuaCode] |
|
45 processScript fileName = do |
|
46 r <- runParserT processFile () "" "" |
|
47 case r of |
|
48 (Left a) -> do |
|
49 putStrLn $ "Error: " ++ (show a) |
|
50 return [] |
|
51 (Right a) -> return a |
|
52 |
|
53 where |
|
54 processFile = do |
|
55 --liftIO $ putStrLn $ "Processing: " ++ fileName |
|
56 f <- liftIO (readFile fileName) |
|
57 setInput f |
|
58 process |
|
59 |
|
60 comment :: ParsecT String u IO LuaCode |
|
61 comment = liftM Comments $ choice [ |
|
62 (try $ string "--[[") >> manyTill anyChar (try $ string "]]") >>= \s -> return $ "--[[" ++ s ++ "]]" |
|
63 , (try $ string "--") >> manyTill anyChar (try newline) >>= \s -> return $ "--" ++ s ++ "\n" |
|
64 ] |
|
65 |
|
66 stringConcat :: ParsecT String u IO () |
|
67 stringConcat = try $ string ".." >> spaces |
|
68 |
|
69 locString :: ParsecT String u IO LuaCode |
|
70 locString = do |
|
71 s <- (try $ optional stringConcat >> string "loc(") >> luaString >>= \s -> char ')' >> return s |
|
72 subString <- liftM (fromMaybe NoCode) . optionMaybe . try $ spaces >> string ".." >> spaces >> codeBlock |
|
73 return $ LuaLocString s subString |
|
74 |
|
75 luaString :: ParsecT String u IO LuaCode |
|
76 luaString = do |
|
77 s <- choice[ |
|
78 (try $ optional stringConcat >> char '\'') >> many (noneOf "'\n") >>= \s -> char '\'' >> return s |
|
79 , (try $ optional stringConcat >> char '"') >> many (noneOf "\"\n") >>= \s -> char '"' >> return s |
|
80 ] |
|
81 subString <- liftM (fromMaybe NoCode) . optionMaybe . try $ spaces >> string ".." >> spaces >> codeBlock |
|
82 return $ LuaString s subString |
|
83 |
|
84 luaOp :: ParsecT String u IO LuaCode |
|
85 luaOp = do |
|
86 s <- many1Till anyChar (lookAhead $ (oneOf "=-.,()[]{}'\"" >> return ()) <|> (try (string "end") >> return ())) |
|
87 subCode <- liftM (fromMaybe NoCode) . optionMaybe . try $ codeBlock |
|
88 return $ LuaOp s subCode |
|
89 |
|
90 codeBlock :: ParsecT String u IO LuaCode |
|
91 codeBlock = do |
|
92 s <- choice [ |
|
93 comment |
|
94 , liftM toChunk $ many1 space |
|
95 , locString |
|
96 , luaString |
|
97 , luaOp |
|
98 , liftM (BlocksList '[') . brackets $ commaSep luaOp |
|
99 , liftM (BlocksList '{') . braces $ commaSep luaOp |
|
100 , liftM (BlocksList '(') . parens $ commaSep luaOp |
|
101 ] |
|
102 |
|
103 return s |
|
104 |
|
105 brackets = between (char '[') (char ']') |
|
106 braces = between (char '{') (char '}') |
|
107 parens = between (char '(') (char ')') |
|
108 commaSep p = p `sepBy` (char ',') |
|
109 |
|
110 otherStuff :: ParsecT String u IO LuaCode |
|
111 otherStuff = liftM (\s -> CodeChunk s NoCode) $ manyTill anyChar (try $ lookAhead codeBlock) |
|
112 |
|
113 process :: ParsecT String u IO [LuaCode] |
|
114 process = do |
|
115 codes <- many $ try $ do |
|
116 a <- otherStuff |
|
117 b <- liftM (fromMaybe (CodeChunk "" NoCode)) $ optionMaybe $ try codeBlock |
|
118 return [a, b] |
|
119 liftIO . putStrLn . unlines . map (renderLua . processLocString) . filter isLocString $ concat codes |
|
120 return $ concat codes |
|
121 |
|
122 listFilesRecursively :: FilePath -> IO [FilePath] |
|
123 listFilesRecursively dir = do |
|
124 fs <- liftM (map (\d -> dir ++ ('/' : d)) . filter ((/=) '.' . head)) $ getDirectoryContents dir |
|
125 dirs <- filterM doesDirectoryExist fs |
|
126 recfs <- mapM listFilesRecursively dirs |
|
127 return . concat $ fs : recfs |
|
128 |
|
129 renderLua :: LuaCode -> String |
|
130 renderLua (Comments str) = str |
|
131 renderLua (LuaLocString lc1 lc2) = let r = renderLua lc2 in "loc(" ++ renderLua lc1 ++ ")" ++ r |
|
132 renderLua (LuaString str lc) = let r = renderLua lc in "\"" ++ str ++ "\"" ++ r |
|
133 renderLua (CodeChunk str lc) = str ++ renderLua lc |
|
134 renderLua (LuaOp str lc) = str ++ renderLua lc |
|
135 renderLua (BlocksList t lcs) = t : (concat . intersperse "," . map renderLua) lcs ++ [mirror t] |
|
136 renderLua NoCode = "" |
|
137 |
|
138 processLocString :: LuaCode -> LuaCode |
|
139 processLocString lcode = let (str, params) = pp lcode in |
|
140 LuaLocString (LuaString str NoCode) |
|
141 (if null params then NoCode else (CodeChunk ".format" $ BlocksList '(' params)) |
|
142 where |
|
143 pp (Comments _) = ("", []) |
|
144 pp (LuaLocString lc1 lc2) = let (s1, p1) = pp lc1; (s2, p2) = pp lc2 in (s1 ++ s2, p1 ++ p2) |
|
145 pp (LuaString str lc) = let (s, p) = pp lc in (str ++ s, p) |
|
146 pp (CodeChunk str lc) = let (s, p) = pp lc in ("%s" ++ s, p) |
|
147 pp (LuaOp str lc) = let (s, p) = pp lc in ("%s" ++ s, [LuaOp str (head $ p ++ [NoCode])]) |
|
148 pp (BlocksList t lcs) = ("", [BlocksList t lcs]) |
|
149 pp NoCode = ("", []) |
|
150 |
|
151 mirror '(' = ')' |
|
152 mirror '[' = ']' |
|
153 mirror '{' = '}' |
|
154 |
|
155 main = do |
|
156 (l18ns, scripts) <- liftM (partition (isPrefixOf "share/hedgewars/Data/Locale") . filter (isSuffixOf ".lua")) |
|
157 $ listFilesRecursively "share/hedgewars/Data" |
|
158 |
|
159 mapM_ processScript scripts |
|
160 |
|
161 --putStrLn $ unlines l18ns |