1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
{-# LANGUAGE ScopedTypeVariables #-}
module PascalPreprocessor where
import Text.Parsec hiding (string')
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 ++ "}"
|
