1 module PascalPreprocessor where |
|
2 |
|
3 import Text.Parsec |
|
4 import Control.Monad.IO.Class |
|
5 import Control.Monad |
|
6 import System.IO |
|
7 import qualified Data.Map as Map |
|
8 import Data.Char |
|
9 |
|
10 |
|
11 -- comments are removed |
|
12 comment = choice [ |
|
13 char '{' >> notFollowedBy (char '$') >> manyTill anyChar (try $ char '}') >> return "" |
|
14 , (try $ string "(*") >> manyTill anyChar (try $ string "*)") >> return "" |
|
15 , (try $ string "//") >> manyTill anyChar (try newline) >> return "\n" |
|
16 ] |
|
17 |
|
18 initDefines = Map.fromList [ |
|
19 ("FPC", "") |
|
20 , ("PAS2C", "") |
|
21 , ("ENDIAN_LITTLE", "") |
|
22 ] |
|
23 |
|
24 preprocess :: String -> IO String |
|
25 preprocess fn = do |
|
26 r <- runParserT (preprocessFile fn) (initDefines, [True]) "" "" |
|
27 case r of |
|
28 (Left a) -> do |
|
29 hPutStrLn stderr (show a) |
|
30 return "" |
|
31 (Right a) -> return a |
|
32 |
|
33 where |
|
34 preprocessFile fn = do |
|
35 f <- liftIO (readFile fn) |
|
36 setInput f |
|
37 preprocessor |
|
38 |
|
39 preprocessor, codeBlock, switch :: ParsecT String (Map.Map String String, [Bool]) IO String |
|
40 |
|
41 preprocessor = chainr codeBlock (return (++)) "" |
|
42 |
|
43 codeBlock = do |
|
44 s <- choice [ |
|
45 switch |
|
46 , comment |
|
47 , char '\'' >> many (noneOf "'\n") >>= \s -> char '\'' >> return ('\'' : s ++ "'") |
|
48 , identifier >>= replace |
|
49 , noneOf "{" >>= \a -> return [a] |
|
50 ] |
|
51 (_, ok) <- getState |
|
52 return $ if and ok then s else "" |
|
53 |
|
54 --otherChar c = c `notElem` "{/('_" && not (isAlphaNum c) |
|
55 identifier = do |
|
56 c <- letter <|> oneOf "_" |
|
57 s <- many (alphaNum <|> oneOf "_") |
|
58 return $ c:s |
|
59 |
|
60 switch = do |
|
61 try $ string "{$" |
|
62 s <- choice [ |
|
63 include |
|
64 , ifdef |
|
65 , if' |
|
66 , elseSwitch |
|
67 , endIf |
|
68 , define |
|
69 , unknown |
|
70 ] |
|
71 return s |
|
72 |
|
73 include = do |
|
74 try $ string "INCLUDE" |
|
75 spaces |
|
76 (char '"') |
|
77 fn <- many1 $ noneOf "\"\n" |
|
78 char '"' |
|
79 spaces |
|
80 char '}' |
|
81 f <- liftIO (readFile fn `catch` error ("File not found: " ++ fn)) |
|
82 c <- getInput |
|
83 setInput $ f ++ c |
|
84 return "" |
|
85 |
|
86 ifdef = do |
|
87 s <- try (string "IFDEF") <|> try (string "IFNDEF") |
|
88 let f = if s == "IFNDEF" then not else id |
|
89 |
|
90 spaces |
|
91 d <- identifier |
|
92 spaces |
|
93 char '}' |
|
94 |
|
95 updateState $ \(m, b) -> |
|
96 (m, (f $ d `Map.member` m) : b) |
|
97 |
|
98 return "" |
|
99 |
|
100 if' = do |
|
101 s <- try (string "IF" >> notFollowedBy alphaNum) |
|
102 |
|
103 manyTill anyChar (char '}') |
|
104 --char '}' |
|
105 |
|
106 updateState $ \(m, b) -> |
|
107 (m, False : b) |
|
108 |
|
109 return "" |
|
110 |
|
111 elseSwitch = do |
|
112 try $ string "ELSE}" |
|
113 updateState $ \(m, b:bs) -> (m, (not b):bs) |
|
114 return "" |
|
115 endIf = do |
|
116 try $ string "ENDIF}" |
|
117 updateState $ \(m, b:bs) -> (m, bs) |
|
118 return "" |
|
119 define = do |
|
120 try $ string "DEFINE" |
|
121 spaces |
|
122 i <- identifier |
|
123 d <- ((string ":=" >> return ()) <|> spaces) >> many (noneOf "}") |
|
124 char '}' |
|
125 updateState $ \(m, b) -> (if (and b) && (head i /= '_') then Map.insert i d m else m, b) |
|
126 return "" |
|
127 replace s = do |
|
128 (m, _) <- getState |
|
129 return $ Map.findWithDefault s s m |
|
130 |
|
131 unknown = do |
|
132 fn <- many1 $ noneOf "}\n" |
|
133 char '}' |
|
134 return $ "{$" ++ fn ++ "}" |
|