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 Control.Exception(catch, IOException)

    10 import Data.Char

    11 import Prelude hiding (catch)

    12 

    13 -- comments are removed

    14 comment = choice [

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

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

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

    18         ]

    19 

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

    21 preprocess inputPath alternateInputPath fn symbols = do

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

    23     case r of

    24          (Left a) -> do

    25              hPutStrLn stderr (show a)

    26              return ""

    27          (Right a) -> return a

    28 

    29     where

    30     preprocessFile fn = do

    31         f <- liftIO (readFile fn)

    32         setInput f

    33         preprocessor

    34 

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

    36 

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

    38 

    39     codeBlock = do

    40         s <- choice [

    41             switch

    42             , comment

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

    44             , identifier >>= replace

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

    46             ]

    47         (_, ok) <- getState

    48         return $ if and ok then s else ""

    49 

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

    51     identifier = do

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

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

    54         return $ c:s

    55 

    56     switch = do

    57         try $ string "{$"

    58         s <- choice [

    59             include

    60             , ifdef

    61             , if'

    62             , elseSwitch

    63             , endIf

    64             , define

    65             , unknown

    66             ]

    67         return s

    68 

    69     include = do

    70         try $ string "INCLUDE"

    71         spaces

    72         (char '"')

    73         fn <- many1 $ noneOf "\"\n"

    74         char '"'

    75         spaces

    76         char '}'

    77         f <- liftIO (readFile (inputPath ++ fn) `catch` (\(exc :: IOException) -> readFile (alternateInputPath ++ fn) `catch` (\(_ :: IOException) -> error ("File not found: " ++ fn))))

    78         c <- getInput

    79         setInput $ f ++ c

    80         return ""

    81 

    82     ifdef = do

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

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

    85 

    86         spaces

    87         d <- identifier

    88         spaces

    89         char '}'

    90 

    91         updateState $ \(m, b) ->

    92             (m, (f $ d `Map.member` m) : b)

    93 

    94         return ""

    95 

    96     if' = do

    97         s <- try (string "IF" >> notFollowedBy alphaNum)

    98 

    99         manyTill anyChar (char '}')

   100         --char '}'

   101 

   102         updateState $ \(m, b) ->

   103             (m, False : b)

   104 

   105         return ""

   106 

   107     elseSwitch = do

   108         try $ string "ELSE}"

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

   110         return ""

   111     endIf = do

   112         try $ string "ENDIF}"

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

   114         return ""

   115     define = do

   116         try $ string "DEFINE"

   117         spaces

   118         i <- identifier

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

   120         char '}'

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

   122         return ""

   123     replace s = do

   124         (m, _) <- getState

   125         return $ Map.findWithDefault s s m

   126 

   127     unknown = do

   128         fn <- many1 $ noneOf "}\n"

   129         char '}'

   130         return $ "{$" ++ fn ++ "}"