{-# LANGUAGE ScopedTypeVariables #-}
module PascalPreprocessor where

import Text.Parsec
import Control.Monad.IO.Class
import Control.Monad
import System.IO
import qualified Data.Map as Map
import qualified Control.Exception as E

char' :: Char -> ParsecT String u IO ()
char' = void . char

string' :: String -> ParsecT String u IO ()
string' = void . string

-- comments are removed
comment :: ParsecT String u IO String
comment = choice [
        char '{' >> notFollowedBy (char '$') >> manyTill anyChar (try $ char '}') >> return ""
        , (try $ string "(*") >> manyTill anyChar (try $ string "*)") >> return ""
        , (try $ string "//") >> manyTill anyChar (try newline) >> return "\n"
        ]

preprocess :: String -> String -> String -> [String] -> IO String
preprocess inputPath alternateInputPath fn symbols = do
    r <- runParserT (preprocessFile (inputPath ++ fn)) (Map.fromList $ map (\s -> (s, "")) symbols, [True]) "" ""
    case r of
         (Left a) -> do
             hPutStrLn stderr (show a)
             return ""
         (Right a) -> return a

    where
    preprocessFile fn' = do
        f <- liftIO (readFile fn')
        setInput f
        preprocessor

    preprocessor, codeBlock, switch :: ParsecT String (Map.Map String String, [Bool]) IO String

    preprocessor = chainr codeBlock (return (++)) ""

    codeBlock = do
        s <- choice [
            switch
            , comment
            , char '\'' >> many (noneOf "'\n") >>= \s -> char '\'' >> return ('\'' : s ++ "'")
            , identifier >>= replace
            , noneOf "{" >>= \a -> return [a]
            ]
        (_, ok) <- getState
        return $ if and ok then s else ""

    --otherChar c = c `notElem` "{/('_" && not (isAlphaNum c)
    identifier = do
        c <- letter <|> oneOf "_"
        s <- many (alphaNum <|> oneOf "_")
        return $ c:s

    switch = do
        try $ string' "{$"
        s <- choice [
            include
            , ifdef
            , if'
            , elseSwitch
            , endIf
            , define
            , unknown
            ]
        return s

    include = do
        try $ string' "INCLUDE"
        spaces
        (char' '"')
        ifn <- many1 $ noneOf "\"\n"
        char' '"'
        spaces
        char' '}'
        f <- liftIO (readFile (inputPath ++ ifn) 
            `E.catch` (\(_ :: E.IOException) -> readFile (alternateInputPath ++ ifn) 
                `E.catch` (\(_ :: E.IOException) -> error $ "File not found: " ++ ifn)
                )
            )
        c <- getInput
        setInput $ f ++ c
        return ""

    ifdef = do
        s <- try (string "IFDEF") <|> try (string "IFNDEF")
        let f = if s == "IFNDEF" then not else id

        spaces
        d <- identifier
        spaces
        char' '}'

        updateState $ \(m, b) ->
            (m, (f $ d `Map.member` m) : b)

        return ""

    if' = do
        try (string' "IF" >> notFollowedBy alphaNum)

        void $ manyTill anyChar (char' '}')
        --char '}'

        updateState $ \(m, b) ->
            (m, False : b)

        return ""

    elseSwitch = do
        try $ string' "ELSE}"
        updateState $ \(m, b:bs) -> (m, (not b):bs)
        return ""
    endIf = do
        try $ string' "ENDIF}"
        updateState $ \(m, _:bs) -> (m, bs)
        return ""
    define = do
        try $ string' "DEFINE"
        spaces
        i <- identifier
        d <- ((string ":=" >> return ()) <|> spaces) >> many (noneOf "}")
        char' '}'
        updateState $ \(m, b) -> (if (and b) && (head i /= '_') then Map.insert i d m else m, b)
        return ""
    replace s = do
        (m, _) <- getState
        return $ Map.findWithDefault s s m

    unknown = do
        un <- many1 $ noneOf "}\n"
        char' '}'
        return $ "{$" ++ un ++ "}"