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