diff -r d8830bd7cb24 -r 27d34e33dabc tools/darkMagic.hs --- /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