tools/darkMagic.hs
author nemo
Thu, 04 Dec 2014 11:11:17 -0500
changeset 10623 81f1cf934827
parent 10433 27d34e33dabc
child 13516 b62b14aa88d4
permissions -rw-r--r--
Skip frame increments if FrameTicks is over 1000 seconds per frame, probably indicating static at that point.

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