--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/darkMagic.hs Thu Oct 09 22:14:55 2014 +0400
@@ -0,0 +1,159 @@
+module Main where
+
+import System.Directory
+import Control.Monad
+import Data.List
+import Text.Parsec
+import Control.Monad.IO.Class
+import Data.Maybe
+
+data LuaCode =
+ Comments String
+ | LuaLocString LuaCode LuaCode
+ | LuaString String LuaCode
+ | CodeChunk String LuaCode
+ | LuaOp String LuaCode
+ | BlocksList Char [LuaCode]
+ | NoCode
+ deriving (Show, Eq)
+
+toChunk a = CodeChunk a NoCode
+
+isLuaString LuaLocString{} = True
+isLuaString LuaString{} = True
+isLuaString _ = False
+
+isLocString (BlocksList _ blocks) = or $ map isLocString blocks
+isLocString LuaLocString{} = True
+isLocString (LuaString _ lc) = isLocString lc
+isLocString (CodeChunk _ lc) = isLocString lc
+isLocString (LuaOp _ lc) = isLocString lc
+isLocString _ = False
+
+many1Till :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
+many1Till p end = do
+ res <- scan
+ if null res then unexpected "many1Till" else return res
+ where
+ scan = do{ end; return [] }
+ <|>
+ do{ x <- p; xs <- scan; return (x:xs) }
+
+processScript :: String -> IO [LuaCode]
+processScript fileName = do
+ r <- runParserT processFile () "" ""
+ case r of
+ (Left a) -> do
+ putStrLn $ "Error: " ++ (show a)
+ return []
+ (Right a) -> return a
+
+ where
+ processFile = do
+ --liftIO $ putStrLn $ "Processing: " ++ fileName
+ f <- liftIO (readFile fileName)
+ setInput f
+ process
+
+ comment :: ParsecT String u IO LuaCode
+ comment = liftM Comments $ choice [
+ (try $ string "--[[") >> manyTill anyChar (try $ string "]]") >>= \s -> return $ "--[[" ++ s ++ "]]"
+ , (try $ string "--") >> manyTill anyChar (try newline) >>= \s -> return $ "--" ++ s ++ "\n"
+ ]
+
+ stringConcat :: ParsecT String u IO ()
+ stringConcat = try $ string ".." >> spaces
+
+ locString :: ParsecT String u IO LuaCode
+ locString = do
+ s <- (try $ optional stringConcat >> string "loc(") >> luaString >>= \s -> char ')' >> return s
+ subString <- liftM (fromMaybe NoCode) . optionMaybe . try $ spaces >> string ".." >> spaces >> codeBlock
+ return $ LuaLocString s subString
+
+ luaString :: ParsecT String u IO LuaCode
+ luaString = do
+ s <- choice[
+ (try $ optional stringConcat >> char '\'') >> many (noneOf "'\n") >>= \s -> char '\'' >> return s
+ , (try $ optional stringConcat >> char '"') >> many (noneOf "\"\n") >>= \s -> char '"' >> return s
+ ]
+ subString <- liftM (fromMaybe NoCode) . optionMaybe . try $ spaces >> string ".." >> spaces >> codeBlock
+ return $ LuaString s subString
+
+ luaOp :: ParsecT String u IO LuaCode
+ luaOp = do
+ s <- many1Till anyChar (lookAhead $ (oneOf "=-.,()[]{}'\"" >> return ()) <|> (try (string "end") >> return ()))
+ subCode <- liftM (fromMaybe NoCode) . optionMaybe . try $ codeBlock
+ return $ LuaOp s subCode
+
+ codeBlock :: ParsecT String u IO LuaCode
+ codeBlock = do
+ s <- choice [
+ comment
+ , liftM toChunk $ many1 space
+ , locString
+ , luaString
+ , luaOp
+ , liftM (BlocksList '[') . brackets $ commaSep luaOp
+ , liftM (BlocksList '{') . braces $ commaSep luaOp
+ , liftM (BlocksList '(') . parens $ commaSep luaOp
+ ]
+
+ return s
+
+ brackets = between (char '[') (char ']')
+ braces = between (char '{') (char '}')
+ parens = between (char '(') (char ')')
+ commaSep p = p `sepBy` (char ',')
+
+ otherStuff :: ParsecT String u IO LuaCode
+ otherStuff = liftM (\s -> CodeChunk s NoCode) $ manyTill anyChar (try $ lookAhead codeBlock)
+
+ process :: ParsecT String u IO [LuaCode]
+ process = do
+ codes <- many $ try $ do
+ a <- otherStuff
+ b <- liftM (fromMaybe (CodeChunk "" NoCode)) $ optionMaybe $ try codeBlock
+ return [a, b]
+ liftIO . putStrLn . unlines . map (renderLua . processLocString) . filter isLocString $ concat codes
+ return $ concat codes
+
+listFilesRecursively :: FilePath -> IO [FilePath]
+listFilesRecursively dir = do
+ fs <- liftM (map (\d -> dir ++ ('/' : d)) . filter ((/=) '.' . head)) $ getDirectoryContents dir
+ dirs <- filterM doesDirectoryExist fs
+ recfs <- mapM listFilesRecursively dirs
+ return . concat $ fs : recfs
+
+renderLua :: LuaCode -> String
+renderLua (Comments str) = str
+renderLua (LuaLocString lc1 lc2) = let r = renderLua lc2 in "loc(" ++ renderLua lc1 ++ ")" ++ r
+renderLua (LuaString str lc) = let r = renderLua lc in "\"" ++ str ++ "\"" ++ r
+renderLua (CodeChunk str lc) = str ++ renderLua lc
+renderLua (LuaOp str lc) = str ++ renderLua lc
+renderLua (BlocksList t lcs) = t : (concat . intersperse "," . map renderLua) lcs ++ [mirror t]
+renderLua NoCode = ""
+
+processLocString :: LuaCode -> LuaCode
+processLocString lcode = let (str, params) = pp lcode in
+ LuaLocString (LuaString str NoCode)
+ (if null params then NoCode else (CodeChunk ".format" $ BlocksList '(' params))
+ where
+ pp (Comments _) = ("", [])
+ pp (LuaLocString lc1 lc2) = let (s1, p1) = pp lc1; (s2, p2) = pp lc2 in (s1 ++ s2, p1 ++ p2)
+ pp (LuaString str lc) = let (s, p) = pp lc in (str ++ s, p)
+ pp (CodeChunk str lc) = let (s, p) = pp lc in ("%s" ++ s, p)
+ pp (LuaOp str lc) = let (s, p) = pp lc in ("%s" ++ s, [LuaOp str (head $ p ++ [NoCode])])
+ pp (BlocksList t lcs) = ("", [BlocksList t lcs])
+ pp NoCode = ("", [])
+
+mirror '(' = ')'
+mirror '[' = ']'
+mirror '{' = '}'
+
+main = do
+ (l18ns, scripts) <- liftM (partition (isPrefixOf "share/hedgewars/Data/Locale") . filter (isSuffixOf ".lua"))
+ $ listFilesRecursively "share/hedgewars/Data"
+
+ mapM_ processScript scripts
+
+ --putStrLn $ unlines l18ns
\ No newline at end of file