tools/darkMagic.hs
author Wuzzy <Wuzzy2@mail.ru>
Sat, 25 Aug 2018 22:02:21 +0200
changeset 13702 dc06ef77a73a
parent 13511 b62b14aa88d4
permissions -rw-r--r--
Don't translate greeting message
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