{-# LANGUAGE FlexibleContexts #-}

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