tools/PascalPreprocessor.hs
author nemo
Fri, 23 Mar 2012 18:20:59 -0400
changeset 6810 5337f554480e
parent 6453 11c578d30bd3
child 6891 ab9843957664
permissions -rw-r--r--
This has bugged me for a while. Since we are missing the source SVGs for this theme, removed the leaves crudely in GIMP. Also added some basic roots. Someone more artistic is encouraged to try and improve it.

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 ++ "}"