--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tools/pas2c/PascalPreprocessor.hs	Tue Nov 10 20:43:13 2015 +0100
@@ -0,0 +1,138 @@
+{-# 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 ++ "}"