{-# 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