|
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 ++ "}" |