tools/pas2c/PascalPreprocessor.hs
author Wuzzy <Wuzzy2@mail.ru>
Thu, 25 Apr 2019 23:01:05 +0200
changeset 14844 e239378a9400
parent 10240 bfae7354d42f
permissions -rw-r--r--
Prevent entering “/”, “\” and “:” in team and scheme names. The name of teams and schems is saved in the file name itself, so these characters would cause trouble as they are used in path names in Linux and Windows.

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

        ds <- (spaces >> identifier) `sepBy` (spaces >> string "OR")
        spaces
        char' '}'

        updateState $ \(m, b) ->
            (m, (f $ any (flip Map.member m) ds) : 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 ++ "}"