10 import Control.Monad.IO.Class |
10 import Control.Monad.IO.Class |
11 import PascalPreprocessor |
11 import PascalPreprocessor |
12 import Control.Exception |
12 import Control.Exception |
13 import System.IO.Error |
13 import System.IO.Error |
14 import qualified Data.Map as Map |
14 import qualified Data.Map as Map |
15 |
15 import Data.List (find) |
16 |
16 |
17 import PascalParser |
17 import PascalParser |
18 import PascalUnitSyntaxTree |
18 import PascalUnitSyntaxTree |
|
19 |
|
20 type RenderState = [(String, String)] |
19 |
21 |
20 pas2C :: String -> IO () |
22 pas2C :: String -> IO () |
21 pas2C fn = do |
23 pas2C fn = do |
22 setCurrentDirectory "../hedgewars/" |
24 setCurrentDirectory "../hedgewars/" |
23 s <- flip execStateT initState $ f fn |
25 s <- flip execStateT initState $ f fn |
34 fc' <- liftIO |
36 fc' <- liftIO |
35 $ tryJust (guard . isDoesNotExistError) |
37 $ tryJust (guard . isDoesNotExistError) |
36 $ preprocess (fileName ++ ".pas") |
38 $ preprocess (fileName ++ ".pas") |
37 case fc' of |
39 case fc' of |
38 (Left a) -> do |
40 (Left a) -> do |
39 modify (Map.insert fileName System) |
41 modify (Map.insert fileName (System [])) |
40 printLn "doesn't exist" |
42 printLn "doesn't exist" |
41 (Right fc) -> do |
43 (Right fc) -> do |
42 print "ok, parsing... " |
44 print "ok, parsing... " |
43 let ptree = parse pascalUnit fileName fc |
45 let ptree = parse pascalUnit fileName fc |
44 case ptree of |
46 case ptree of |
50 printLn "ok" |
52 printLn "ok" |
51 modify (Map.insert fileName a) |
53 modify (Map.insert fileName a) |
52 mapM_ f (usesFiles a) |
54 mapM_ f (usesFiles a) |
53 |
55 |
54 toCFiles :: (String, PascalUnit) -> IO () |
56 toCFiles :: (String, PascalUnit) -> IO () |
55 toCFiles (_, System) = return () |
57 toCFiles (_, System _) = return () |
56 toCFiles p@(fn, pu) = do |
58 toCFiles p@(fn, pu) = do |
57 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
59 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
58 toCFiles' p |
60 toCFiles' p |
59 where |
61 where |
60 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C . pascal2C) p |
62 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C . pascal2C) p |
61 toCFiles' (fn, (Unit _ interface implementation _ _)) = do |
63 toCFiles' (fn, (Unit _ interface implementation _ _)) = do |
62 writeFile (fn ++ ".h") $ "#pragma once\n" ++ (render2C . interface2C $ interface) |
64 writeFile (fn ++ ".h") $ "#pragma once\n" ++ (render2C . interface2C $ interface) |
63 writeFile (fn ++ ".c") $ (render2C . implementation2C) implementation |
65 writeFile (fn ++ ".c") $ (render2C . implementation2C) implementation |
64 |
66 |
65 system :: [(String, String)] |
67 render2C = render . flip evalState [] |
66 system = [] |
|
67 |
|
68 render2C = render . flip evalState system |
|
69 |
68 |
70 usesFiles :: PascalUnit -> [String] |
69 usesFiles :: PascalUnit -> [String] |
71 usesFiles (Program _ (Implementation uses _) _) = uses2List uses |
70 usesFiles (Program _ (Implementation uses _) _) = "pas2cSystem" : uses2List uses |
72 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = uses2List uses1 ++ uses2List uses2 |
71 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = "pas2cSystem" : uses2List uses1 ++ uses2List uses2 |
73 |
72 usesFiles (System {}) = [] |
74 |
73 |
75 |
74 |
76 pascal2C :: PascalUnit -> State a Doc |
75 pascal2C :: PascalUnit -> State RenderState Doc |
77 pascal2C (Unit _ interface implementation init fin) = |
76 pascal2C (Unit _ interface implementation init fin) = |
78 liftM2 ($+$) (interface2C interface) (implementation2C implementation) |
77 liftM2 ($+$) (interface2C interface) (implementation2C implementation) |
79 |
78 |
80 pascal2C (Program _ implementation mainFunction) = do |
79 pascal2C (Program _ implementation mainFunction) = do |
81 impl <- implementation2C implementation |
80 impl <- implementation2C implementation |
83 (FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [] (Just (TypesAndVars [], mainFunction))) |
82 (FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [] (Just (TypesAndVars [], mainFunction))) |
84 return $ impl $+$ main |
83 return $ impl $+$ main |
85 |
84 |
86 |
85 |
87 |
86 |
88 interface2C :: Interface -> State a Doc |
87 interface2C :: Interface -> State RenderState Doc |
89 interface2C (Interface uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars) |
88 interface2C (Interface uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars) |
90 |
89 |
91 implementation2C :: Implementation -> State a Doc |
90 implementation2C :: Implementation -> State RenderState Doc |
92 implementation2C (Implementation uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars) |
91 implementation2C (Implementation uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars) |
93 |
92 |
94 |
93 |
95 typesAndVars2C :: Bool -> TypesAndVars -> State a Doc |
94 typesAndVars2C :: Bool -> TypesAndVars -> State RenderState Doc |
96 typesAndVars2C b (TypesAndVars ts) = liftM vcat $ mapM (tvar2C b) ts |
95 typesAndVars2C b (TypesAndVars ts) = liftM vcat $ mapM (tvar2C b) ts |
97 |
96 |
98 uses2C :: Uses -> State a Doc |
97 uses2C :: Uses -> State RenderState Doc |
99 uses2C uses = return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
98 uses2C uses = return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
100 |
99 |
101 uses2List :: Uses -> [String] |
100 uses2List :: Uses -> [String] |
102 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
101 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
103 |
102 |
104 id2C :: Bool -> Identifier -> State a Doc |
103 |
105 id2C True (Identifier i _) = return $ text i |
104 id2C :: Bool -> Identifier -> State RenderState Doc |
106 |
105 id2C True (Identifier i _) = do |
107 tvar2C :: Bool -> TypeVarDeclaration -> State a Doc |
106 modify (\s -> (map toLower i, i) : s) |
|
107 return $ text i |
|
108 id2C False (Identifier i _) = do |
|
109 let i' = map toLower i |
|
110 v <- gets $ find (\(a, _) -> a == i') |
|
111 if isNothing v then |
|
112 error $ "Not defined: " ++ i' |
|
113 else |
|
114 return . text . snd . fromJust $ v |
|
115 |
|
116 |
|
117 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc |
108 tvar2C _ (FunctionDeclaration name returnType params Nothing) = do |
118 tvar2C _ (FunctionDeclaration name returnType params Nothing) = do |
109 t <- type2C returnType |
119 t <- type2C returnType |
110 p <- liftM hcat $ mapM (tvar2C False) params |
120 p <- liftM hcat $ mapM (tvar2C False) params |
111 n <- id2C True name |
121 n <- id2C True name |
112 return $ t <+> n <> parens p <> text ";" |
122 return $ t <+> n <> parens p <> text ";" |
143 initExpr Nothing = return $ empty |
153 initExpr Nothing = return $ empty |
144 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
154 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
145 tvar2C f (OperatorDeclaration op _ ret params body) = |
155 tvar2C f (OperatorDeclaration op _ ret params body) = |
146 tvar2C f (FunctionDeclaration (Identifier ("<op " ++ op ++ ">") Unknown) ret params body) |
156 tvar2C f (FunctionDeclaration (Identifier ("<op " ++ op ++ ">") Unknown) ret params body) |
147 |
157 |
148 initExpr2C :: InitExpression -> State a Doc |
158 initExpr2C :: InitExpression -> State RenderState Doc |
149 initExpr2C (InitBinOp op expr1 expr2) = do |
159 initExpr2C (InitBinOp op expr1 expr2) = do |
150 e1 <- initExpr2C expr1 |
160 e1 <- initExpr2C expr1 |
151 e2 <- initExpr2C expr2 |
161 e2 <- initExpr2C expr2 |
152 o <- op2C op |
162 o <- op2C op |
153 return $ parens $ e1 <+> o <+> e2 |
163 return $ parens $ e1 <+> o <+> e2 |
157 initExpr2C (InitString s) = return $ doubleQuotes $ text s |
167 initExpr2C (InitString s) = return $ doubleQuotes $ text s |
158 initExpr2C (InitReference i) = id2C False i |
168 initExpr2C (InitReference i) = id2C False i |
159 initExpr2C _ = return $ text "<<expression>>" |
169 initExpr2C _ = return $ text "<<expression>>" |
160 |
170 |
161 |
171 |
162 type2C :: TypeDecl -> State a Doc |
172 type2C :: TypeDecl -> State RenderState Doc |
163 type2C UnknownType = return $ text "void" |
173 type2C UnknownType = return $ text "void" |
164 type2C (String l) = return $ text $ "string" ++ show l |
174 type2C (String l) = return $ text $ "string" ++ show l |
165 type2C (SimpleType i) = id2C True i |
175 type2C (SimpleType i) = id2C True i |
166 type2C (PointerTo t) = liftM (<> text "*") $ type2C t |
176 type2C (PointerTo t) = liftM (<> text "*") $ type2C t |
167 type2C (RecordType tvs union) = do |
177 type2C (RecordType tvs union) = do |
171 type2C (Sequence ids) = return $ text "<<sequence type>>" |
181 type2C (Sequence ids) = return $ text "<<sequence type>>" |
172 type2C (ArrayDecl r t) = return $ text "<<array type>>" |
182 type2C (ArrayDecl r t) = return $ text "<<array type>>" |
173 type2C (Set t) = return $ text "<<set>>" |
183 type2C (Set t) = return $ text "<<set>>" |
174 type2C (FunctionType returnType params) = return $ text "<<function>>" |
184 type2C (FunctionType returnType params) = return $ text "<<function>>" |
175 |
185 |
176 phrase2C :: Phrase -> State a Doc |
186 phrase2C :: Phrase -> State RenderState Doc |
177 phrase2C (Phrases p) = do |
187 phrase2C (Phrases p) = do |
178 ps <- mapM phrase2C p |
188 ps <- mapM phrase2C p |
179 return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" |
189 return $ text "{" $+$ (nest 4 . vcat $ ps) $+$ text "}" |
180 phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f |
190 phrase2C (ProcCall f@(FunCall {}) []) = liftM (<> semi) $ ref2C f |
181 phrase2C (ProcCall ref params) = do |
191 phrase2C (ProcCall ref params) = do |
204 e <- expr2C expr |
214 e <- expr2C expr |
205 cs <- mapM case2C cases |
215 cs <- mapM case2C cases |
206 return $ |
216 return $ |
207 text "switch" <> parens e <> text "of" $+$ (nest 4 . vcat) cs |
217 text "switch" <> parens e <> text "of" $+$ (nest 4 . vcat) cs |
208 where |
218 where |
209 case2C :: ([InitExpression], Phrase) -> State a Doc |
219 case2C :: ([InitExpression], Phrase) -> State RenderState Doc |
210 case2C (e, p) = do |
220 case2C (e, p) = do |
211 ie <- mapM initExpr2C e |
221 ie <- mapM initExpr2C e |
212 ph <- phrase2C p |
222 ph <- phrase2C p |
213 return $ |
223 return $ |
214 text "case" <+> parens (hsep . punctuate (char ',') $ ie) <> char ':' <> nest 4 (ph $+$ text "break;") |
224 text "case" <+> parens (hsep . punctuate (char ',') $ ie) <> char ':' <> nest 4 (ph $+$ text "break;") |
256 return $ |
266 return $ |
257 r <> parens (hsep . punctuate (char ',') $ ps) |
267 r <> parens (hsep . punctuate (char ',') $ ps) |
258 expr2C _ = return $ text "<<expression>>" |
268 expr2C _ = return $ text "<<expression>>" |
259 |
269 |
260 |
270 |
261 ref2C :: Reference -> State a Doc |
271 ref2C :: Reference -> State RenderState Doc |
262 ref2C (ArrayElement exprs ref) = do |
272 ref2C (ArrayElement exprs ref) = do |
263 r <- ref2C ref |
273 r <- ref2C ref |
264 es <- mapM expr2C exprs |
274 es <- mapM expr2C exprs |
265 return $ r <> (brackets . hcat) (punctuate comma es) |
275 return $ r <> (brackets . hcat) (punctuate comma es) |
266 ref2C (SimpleReference name) = id2C False name |
276 ref2C (SimpleReference name) = id2C False name |
288 e <- expr2C expr |
298 e <- expr2C expr |
289 return $ parens t <> e |
299 return $ parens t <> e |
290 ref2C (RefExpression expr) = expr2C expr |
300 ref2C (RefExpression expr) = expr2C expr |
291 |
301 |
292 |
302 |
293 op2C :: String -> State a Doc |
303 op2C :: String -> State RenderState Doc |
294 op2C "or" = return $ text "|" |
304 op2C "or" = return $ text "|" |
295 op2C "and" = return $ text "&" |
305 op2C "and" = return $ text "&" |
296 op2C "not" = return $ text "!" |
306 op2C "not" = return $ text "!" |
297 op2C "xor" = return $ text "^" |
307 op2C "xor" = return $ text "^" |
298 op2C "div" = return $ text "/" |
308 op2C "div" = return $ text "/" |