|
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 , ("S3D_DISABLED", "") |
|
23 ] |
|
24 |
|
25 preprocess :: String -> String -> String -> IO String |
|
26 preprocess inputPath alternateInputPath fn = do |
|
27 r <- runParserT (preprocessFile (inputPath ++ fn)) (initDefines, [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 fn <- many1 $ noneOf "\"\n" |
|
79 char '"' |
|
80 spaces |
|
81 char '}' |
|
82 f <- liftIO (readFile (inputPath ++ fn) `catch` (\exc -> readFile (alternateInputPath ++ fn) `catch` error ("File not found: " ++ fn))) |
|
83 c <- getInput |
|
84 setInput $ f ++ c |
|
85 return "" |
|
86 |
|
87 ifdef = do |
|
88 s <- try (string "IFDEF") <|> try (string "IFNDEF") |
|
89 let f = if s == "IFNDEF" then not else id |
|
90 |
|
91 spaces |
|
92 d <- identifier |
|
93 spaces |
|
94 char '}' |
|
95 |
|
96 updateState $ \(m, b) -> |
|
97 (m, (f $ d `Map.member` m) : b) |
|
98 |
|
99 return "" |
|
100 |
|
101 if' = do |
|
102 s <- try (string "IF" >> notFollowedBy alphaNum) |
|
103 |
|
104 manyTill anyChar (char '}') |
|
105 --char '}' |
|
106 |
|
107 updateState $ \(m, b) -> |
|
108 (m, False : b) |
|
109 |
|
110 return "" |
|
111 |
|
112 elseSwitch = do |
|
113 try $ string "ELSE}" |
|
114 updateState $ \(m, b:bs) -> (m, (not b):bs) |
|
115 return "" |
|
116 endIf = do |
|
117 try $ string "ENDIF}" |
|
118 updateState $ \(m, b:bs) -> (m, bs) |
|
119 return "" |
|
120 define = do |
|
121 try $ string "DEFINE" |
|
122 spaces |
|
123 i <- identifier |
|
124 d <- ((string ":=" >> return ()) <|> spaces) >> many (noneOf "}") |
|
125 char '}' |
|
126 updateState $ \(m, b) -> (if (and b) && (head i /= '_') then Map.insert i d m else m, b) |
|
127 return "" |
|
128 replace s = do |
|
129 (m, _) <- getState |
|
130 return $ Map.findWithDefault s s m |
|
131 |
|
132 unknown = do |
|
133 fn <- many1 $ noneOf "}\n" |
|
134 char '}' |
|
135 return $ "{$" ++ fn ++ "}" |