tools/darkMagic.hs
author Wuzzy <Wuzzy2@mail.ru>
Mon, 16 Sep 2019 17:33:49 +0200
changeset 15410 8504fee3b601
parent 13511 b62b14aa88d4
permissions -rw-r--r--
Racer: Fix weird water splashes after waypoint placement Does not affect official racer, as only waypoint placement is touched. The reason was that the air attack gear sometimes was not deleted fast enough so it might occassionally drop some air bombs (these are deleted now). Also, the airplane position was set to water level, which caused another water splash.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
13511
b62b14aa88d4 Document and clean up tools directory a bit
Wuzzy <Wuzzy2@mail.ru>
parents: 10433
diff changeset
     1
{-# LANGUAGE FlexibleContexts #-}
b62b14aa88d4 Document and clean up tools directory a bit
Wuzzy <Wuzzy2@mail.ru>
parents: 10433
diff changeset
     2
10433
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
     3
module Main where
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
     4
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
     5
import System.Directory
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
     6
import Control.Monad
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
     7
import Data.List
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
     8
import Text.Parsec
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
     9
import Control.Monad.IO.Class
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    10
import Data.Maybe
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    11
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    12
data LuaCode =
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    13
    Comments String
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    14
        | LuaLocString LuaCode LuaCode
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    15
        | LuaString String LuaCode
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    16
        | CodeChunk String LuaCode
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    17
        | LuaOp String LuaCode
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    18
        | BlocksList Char [LuaCode]
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    19
        | NoCode
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    20
        deriving (Show, Eq)
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    21
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    22
toChunk a = CodeChunk a NoCode
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    23
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    24
isLuaString LuaLocString{} = True
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    25
isLuaString LuaString{} = True
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    26
isLuaString _ = False
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    27
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    28
isLocString (BlocksList _ blocks) = or $ map isLocString blocks
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    29
isLocString LuaLocString{} = True
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    30
isLocString (LuaString _ lc) = isLocString lc
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    31
isLocString (CodeChunk _ lc) = isLocString lc
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    32
isLocString (LuaOp _ lc) = isLocString lc
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    33
isLocString _ = False
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    34
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    35
many1Till :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m end -> ParsecT s u m [a]
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    36
many1Till p end      = do
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    37
    res <- scan
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    38
    if null res then unexpected "many1Till" else return res
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    39
                    where
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    40
                    scan  = do{ end; return [] }
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    41
                            <|>
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    42
                            do{ x <- p; xs <- scan; return (x:xs) }
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    43
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    44
processScript :: String -> IO [LuaCode]
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    45
processScript fileName = do
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    46
    r <- runParserT processFile () "" ""
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    47
    case r of
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    48
         (Left a) -> do
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    49
             putStrLn $ "Error: " ++ (show a)
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    50
             return []
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    51
         (Right a) -> return a
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    52
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    53
    where
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    54
    processFile = do
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    55
        --liftIO $ putStrLn $ "Processing: " ++ fileName
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    56
        f <- liftIO (readFile fileName)
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    57
        setInput f
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    58
        process
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    59
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    60
    comment :: ParsecT String u IO LuaCode
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    61
    comment = liftM Comments $ choice [
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    62
            (try $ string "--[[") >> manyTill anyChar (try $ string "]]") >>= \s -> return $ "--[[" ++ s ++ "]]"
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    63
            , (try $ string "--") >> manyTill anyChar (try newline) >>= \s -> return $ "--" ++ s ++ "\n"
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    64
            ]
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    65
            
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    66
    stringConcat :: ParsecT String u IO ()
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    67
    stringConcat = try $ string ".." >> spaces
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    68
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    69
    locString :: ParsecT String u IO LuaCode
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    70
    locString = do
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    71
        s <- (try $ optional stringConcat >> string "loc(") >> luaString >>= \s -> char ')' >> return s
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    72
        subString <- liftM (fromMaybe NoCode) . optionMaybe . try $ spaces >> string ".." >> spaces >> codeBlock
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    73
        return $ LuaLocString s subString
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    74
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    75
    luaString :: ParsecT String u IO LuaCode
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    76
    luaString = do
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    77
        s <- choice[
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    78
            (try $ optional stringConcat >> char '\'') >> many (noneOf "'\n") >>= \s -> char '\'' >> return s
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    79
            , (try $ optional stringConcat >> char '"') >> many (noneOf "\"\n") >>= \s -> char '"' >> return s
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    80
            ]
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    81
        subString <- liftM (fromMaybe NoCode) . optionMaybe . try $ spaces >> string ".." >> spaces >> codeBlock
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    82
        return $ LuaString s subString
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    83
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    84
    luaOp :: ParsecT String u IO LuaCode
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    85
    luaOp = do
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    86
        s <- many1Till anyChar (lookAhead $ (oneOf "=-.,()[]{}'\"" >> return ()) <|> (try (string "end") >> return ()))
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    87
        subCode <- liftM (fromMaybe NoCode) . optionMaybe . try $ codeBlock
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    88
        return $ LuaOp s subCode
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    89
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    90
    codeBlock :: ParsecT String u IO LuaCode
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    91
    codeBlock = do
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    92
        s <- choice [
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    93
            comment
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    94
            , liftM toChunk $ many1 space
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    95
            , locString
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    96
            , luaString
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    97
            , luaOp
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    98
            , liftM (BlocksList '[') . brackets $ commaSep luaOp
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
    99
            , liftM (BlocksList '{') . braces $ commaSep luaOp
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   100
            , liftM (BlocksList '(') . parens $ commaSep luaOp
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   101
            ]
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   102
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   103
        return s
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   104
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   105
    brackets = between (char '[') (char ']')
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   106
    braces = between (char '{') (char '}')
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   107
    parens = between (char '(') (char ')')
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   108
    commaSep p  = p `sepBy` (char ',')
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   109
    
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   110
    otherStuff :: ParsecT String u IO LuaCode
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   111
    otherStuff = liftM (\s -> CodeChunk s NoCode) $ manyTill anyChar (try $ lookAhead codeBlock)
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   112
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   113
    process :: ParsecT String u IO [LuaCode]
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   114
    process = do
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   115
        codes <- many $ try $ do
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   116
            a <- otherStuff
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   117
            b <- liftM (fromMaybe (CodeChunk "" NoCode)) $ optionMaybe $ try codeBlock
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   118
            return [a, b]
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   119
        liftIO . putStrLn . unlines . map (renderLua . processLocString) . filter isLocString $ concat codes
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   120
        return $ concat codes
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   121
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   122
listFilesRecursively :: FilePath -> IO [FilePath]
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   123
listFilesRecursively dir = do
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   124
    fs <- liftM (map (\d -> dir ++ ('/' : d)) . filter ((/=) '.' . head)) $ getDirectoryContents dir
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   125
    dirs <- filterM doesDirectoryExist fs
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   126
    recfs <- mapM listFilesRecursively dirs
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   127
    return . concat $ fs : recfs
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   128
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   129
renderLua :: LuaCode -> String
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   130
renderLua (Comments str) = str
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   131
renderLua (LuaLocString lc1 lc2) = let r = renderLua lc2 in "loc(" ++ renderLua lc1 ++ ")" ++ r
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   132
renderLua (LuaString str lc) = let r = renderLua lc in "\"" ++ str ++ "\"" ++ r
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   133
renderLua (CodeChunk str lc) = str ++ renderLua lc
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   134
renderLua (LuaOp str lc) = str ++ renderLua lc
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   135
renderLua (BlocksList t lcs) = t : (concat . intersperse "," . map renderLua) lcs ++ [mirror t]
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   136
renderLua NoCode = ""
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   137
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   138
processLocString :: LuaCode -> LuaCode
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   139
processLocString lcode = let (str, params) = pp lcode in
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   140
                          LuaLocString (LuaString str NoCode) 
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   141
                            (if null params then NoCode else (CodeChunk ".format" $ BlocksList '(' params))
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   142
    where
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   143
        pp (Comments _) = ("", [])
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   144
        pp (LuaLocString lc1 lc2) = let (s1, p1) = pp lc1; (s2, p2) = pp lc2 in (s1 ++ s2, p1 ++ p2)
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   145
        pp (LuaString str lc) = let (s, p) = pp lc in (str ++ s, p)
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   146
        pp (CodeChunk str lc) = let (s, p) = pp lc in ("%s" ++ s, p)
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   147
        pp (LuaOp str lc) = let (s, p) = pp lc in ("%s" ++ s, [LuaOp str (head $ p ++ [NoCode])])
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   148
        pp (BlocksList t lcs) = ("", [BlocksList t lcs])
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   149
        pp NoCode = ("", [])
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   150
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   151
mirror '(' = ')'
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   152
mirror '[' = ']'
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   153
mirror '{' = '}'
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   154
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   155
main = do
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   156
    (l18ns, scripts) <- liftM (partition (isPrefixOf "share/hedgewars/Data/Locale") . filter (isSuffixOf ".lua")) 
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   157
        $ listFilesRecursively "share/hedgewars/Data"
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   158
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   159
    mapM_ processScript scripts
27d34e33dabc some unfinished stuff
unc0rr
parents:
diff changeset
   160
13511
b62b14aa88d4 Document and clean up tools directory a bit
Wuzzy <Wuzzy2@mail.ru>
parents: 10433
diff changeset
   161
    --putStrLn $ unlines l18ns