+
−module PascalPreprocessor where
+
−
+
−import Text.Parsec
+
−import Control.Monad.IO.Class
+
−import Control.Monad
+
−import System.IO
+
−import qualified Data.Map as Map
+
−import Data.Char
+
−
+
−
+
−-- comments are removed
+
−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"
+
−        ]
+
−
+
−initDefines = Map.fromList [("FPC", "")]
+
−        
+
−preprocess :: String -> IO String
+
−preprocess fn = do
+
−    r <- runParserT (preprocessFile fn) (initDefines, [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 '"')
+
−        fn <- many1 $ noneOf "\"\n"
+
−        char '"'
+
−        spaces
+
−        char '}'
+
−        f <- liftIO (readFile fn)
+
−        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
+
−        s <- try (string "IF" >> notFollowedBy alphaNum)
+
−        
+
−        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, b: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 then Map.insert i d m else m, b)
+
−        return ""
+
−    replace s = do
+
−        (m, _) <- getState
+
−        return $ Map.findWithDefault s s m
+
−        
+
−    unknown = do
+
−        fn <- many1 $ noneOf "}\n"
+
−        char '}'
+
−        return $ "{$" ++ fn ++ "}"