1 {-# LANGUAGE ScopedTypeVariables #-}

     2 module PascalPreprocessor where

     3 

     4 import Text.Parsec

     5 import Control.Monad.IO.Class

     6 import Control.Monad

     7 import System.IO

     8 import qualified Data.Map as Map

     9 import qualified Control.Exception as E

    10 

    11 char' :: Char -> ParsecT String u IO ()

    12 char' = void . char

    13 

    14 string' :: String -> ParsecT String u IO ()

    15 string' = void . string

    16 

    17 -- comments are removed

    18 comment :: ParsecT String u IO String

    19 comment = choice [

    20         char '{' >> notFollowedBy (char '$') >> manyTill anyChar (try $ char '}') >> return ""

    21         , (try $ string "(*") >> manyTill anyChar (try $ string "*)") >> return ""

    22         , (try $ string "//") >> manyTill anyChar (try newline) >> return "\n"

    23         ]

    24 

    25 preprocess :: String -> String -> String -> [String] -> IO String

    26 preprocess inputPath alternateInputPath fn symbols = do

    27     r <- runParserT (preprocessFile (inputPath ++ fn)) (Map.fromList $ map (\s -> (s, "")) symbols, [True]) "" ""

    28     case r of

    29          (Left a) -> do

    30              hPutStrLn stderr (show a)

    31              return ""

    32          (Right a) -> return a

    33 

    34     where

    35     preprocessFile fn' = do

    36         f <- liftIO (readFile fn')

    37         setInput f

    38         preprocessor

    39 

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

    41 

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

    43 

    44     codeBlock = do

    45         s <- choice [

    46             switch

    47             , comment

    48             , char '\'' >> many (noneOf "'\n") >>= \s -> char '\'' >> return ('\'' : s ++ "'")

    49             , identifier >>= replace

    50             , noneOf "{" >>= \a -> return [a]

    51             ]

    52         (_, ok) <- getState

    53         return $ if and ok then s else ""

    54 

    55     --otherChar c = c `notElem` "{/('_" && not (isAlphaNum c)

    56     identifier = do

    57         c <- letter <|> oneOf "_"

    58         s <- many (alphaNum <|> oneOf "_")

    59         return $ c:s

    60 

    61     switch = do

    62         try $ string' "{$"

    63         s <- choice [

    64             include

    65             , ifdef

    66             , if'

    67             , elseSwitch

    68             , endIf

    69             , define

    70             , unknown

    71             ]

    72         return s

    73 

    74     include = do

    75         try $ string' "INCLUDE"

    76         spaces

    77         (char' '"')

    78         ifn <- many1 $ noneOf "\"\n"

    79         char' '"'

    80         spaces

    81         char' '}'

    82         f <- liftIO (readFile (inputPath ++ ifn) 

    83             `E.catch` (\(_ :: E.IOException) -> readFile (alternateInputPath ++ ifn) 

    84                 `E.catch` (\(_ :: E.IOException) -> error $ "File not found: " ++ ifn)

    85                 )

    86             )

    87         c <- getInput

    88         setInput $ f ++ c

    89         return ""

    90 

    91     ifdef = do

    92         s <- try (string "IFDEF") <|> try (string "IFNDEF")

    93         let f = if s == "IFNDEF" then not else id

    94 

    95         ds <- (spaces >> identifier) `sepBy` (spaces >> string "OR")

    96         spaces

    97         char' '}'

    98 

    99         updateState $ \(m, b) ->

   100             (m, (f $ any (flip Map.member m) ds) : b)

   101 

   102         return ""

   103 

   104     if' = do

   105         try (string' "IF" >> notFollowedBy alphaNum)

   106 

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

   108         --char '}'

   109 

   110         updateState $ \(m, b) ->

   111             (m, False : b)

   112 

   113         return ""

   114 

   115     elseSwitch = do

   116         try $ string' "ELSE}"

   117         updateState $ \(m, b:bs) -> (m, (not b):bs)

   118         return ""

   119     endIf = do

   120         try $ string' "ENDIF}"

   121         updateState $ \(m, _:bs) -> (m, bs)

   122         return ""

   123     define = do

   124         try $ string' "DEFINE"

   125         spaces

   126         i <- identifier

   127         d <- ((string ":=" >> return ()) <|> spaces) >> many (noneOf "}")

   128         char' '}'

   129         updateState $ \(m, b) -> (if (and b) && (head i /= '_') then Map.insert i d m else m, b)

   130         return ""

   131     replace s = do

   132         (m, _) <- getState

   133         return $ Map.findWithDefault s s m

   134 

   135     unknown = do

   136         un <- many1 $ noneOf "}\n"

   137         char' '}'

   138         return $ "{$" ++ un ++ "}"