15 import Data.List (find) |
15 import Data.List (find) |
16 |
16 |
17 import PascalParser |
17 import PascalParser |
18 import PascalUnitSyntaxTree |
18 import PascalUnitSyntaxTree |
19 |
19 |
|
20 |
|
21 type Record = (String, (String, BaseType)) |
20 data RenderState = RenderState |
22 data RenderState = RenderState |
21 { |
23 { |
22 currentScope :: [(String, String)], |
24 currentScope :: [Record], |
23 namespaces :: Map.Map String [(String, String)] |
25 lastType :: BaseType, |
|
26 namespaces :: Map.Map String [Record] |
24 } |
27 } |
25 |
28 |
26 pas2C :: String -> IO () |
29 pas2C :: String -> IO () |
27 pas2C fn = do |
30 pas2C fn = do |
28 setCurrentDirectory "../hedgewars/" |
31 setCurrentDirectory "../hedgewars/" |
62 renderCFiles units = do |
65 renderCFiles units = do |
63 let u = Map.toList units |
66 let u = Map.toList units |
64 let ns = Map.map toNamespace units |
67 let ns = Map.map toNamespace units |
65 mapM_ (toCFiles ns) u |
68 mapM_ (toCFiles ns) u |
66 where |
69 where |
67 toNamespace :: PascalUnit -> [(String, String)] |
70 toNamespace :: PascalUnit -> [Record] |
68 toNamespace = concatMap tv2id . extractTVs |
71 toNamespace = concatMap tv2id . extractTVs |
69 |
72 |
70 extractTVs (System tv) = tv |
73 extractTVs (System tv) = tv |
71 extractTVs (Program {}) = [] |
74 extractTVs (Program {}) = [] |
72 extractTVs (Unit _ (Interface _ (TypesAndVars tv)) _ _ _) = tv |
75 extractTVs (Unit _ (Interface _ (TypesAndVars tv)) _ _ _) = tv |
73 |
76 |
74 tv2id :: TypeVarDeclaration -> [(String, String)] |
77 tv2id :: TypeVarDeclaration -> [Record] |
75 tv2id (TypeDeclaration i (Sequence ids)) = map (\(Identifier i _) -> fi i) $ i : ids |
78 tv2id (TypeDeclaration i t@(Sequence ids)) = map (\(Identifier i _) -> fi i (type2BaseType t)) $ i : ids |
76 tv2id (TypeDeclaration (Identifier i _) _) = [(map toLower i, i)] |
79 tv2id (TypeDeclaration (Identifier i _) t) = [(map toLower i, (i, type2BaseType t))] |
77 tv2id (VarDeclaration _ (ids, _) _) = map (\(Identifier i _) -> fi i) ids |
80 tv2id (VarDeclaration _ (ids, t) _) = map (\(Identifier i _) -> fi i (type2BaseType t)) ids |
78 tv2id (FunctionDeclaration (Identifier i _) _ _ _) = [fi i] |
81 tv2id (FunctionDeclaration (Identifier i _) _ _ _) = [fi i BTUnknown] |
79 tv2id (OperatorDeclaration i _ _ _ _) = [fi i] |
82 tv2id (OperatorDeclaration i _ _ _ _) = [fi i BTUnknown] |
80 fi i = (map toLower i, i) |
83 fi i t = (map toLower i, (i, t)) |
81 |
84 |
82 |
85 |
83 toCFiles :: Map.Map String [(String, String)] -> (String, PascalUnit) -> IO () |
86 toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO () |
84 toCFiles _ (_, System _) = return () |
87 toCFiles _ (_, System _) = return () |
85 toCFiles ns p@(fn, pu) = do |
88 toCFiles ns p@(fn, pu) = do |
86 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
89 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
87 toCFiles' p |
90 toCFiles' p |
88 where |
91 where |
89 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C (RenderState [] ns) . pascal2C) p |
92 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p |
90 toCFiles' (fn, (Unit _ interface implementation _ _)) = do |
93 toCFiles' (fn, (Unit _ interface implementation _ _)) = do |
91 let (a, s) = runState (interface2C interface) (RenderState [] ns) |
94 let (a, s) = runState (interface2C interface) initialState |
92 writeFile (fn ++ ".h") $ "#pragma once\n" ++ (render a) |
95 writeFile (fn ++ ".h") $ "#pragma once\n" ++ (render a) |
93 writeFile (fn ++ ".c") $ (render2C s . implementation2C) implementation |
96 writeFile (fn ++ ".c") $ (render2C s . implementation2C) implementation |
|
97 initialState = RenderState [] BTUnknown ns |
94 |
98 |
95 render2C :: RenderState -> State RenderState Doc -> String |
99 render2C :: RenderState -> State RenderState Doc -> String |
96 render2C a = render . flip evalState a |
100 render2C a = render . flip evalState a |
97 |
101 |
98 usesFiles :: PascalUnit -> [String] |
102 usesFiles :: PascalUnit -> [String] |
137 uses2List :: Uses -> [String] |
141 uses2List :: Uses -> [String] |
138 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
142 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
139 |
143 |
140 |
144 |
141 id2C :: Bool -> Identifier -> State RenderState Doc |
145 id2C :: Bool -> Identifier -> State RenderState Doc |
142 id2C True (Identifier i _) = do |
146 id2C True (Identifier i t) = do |
143 modify (\s -> s{currentScope = (map toLower i, i) : currentScope s}) |
147 modify (\s -> s{currentScope = (map toLower i, (i, t)) : currentScope s}) |
144 return $ text i |
148 return $ text i |
145 id2C False (Identifier i _) = do |
149 id2C False (Identifier i t) = do |
146 let i' = map toLower i |
150 let i' = map toLower i |
147 v <- gets $ find (\(a, _) -> a == i') . currentScope |
151 v <- gets $ find (\(a, _) -> a == i') . currentScope |
148 --ns <- gets currentScope |
152 --ns <- gets currentScope |
|
153 modify (\s -> s{lastType = t}) |
149 if isNothing v then |
154 if isNothing v then |
150 error $ "Not defined: '" ++ i' ++ "'"-- ++ show ns |
155 error $ "Not defined: '" ++ i' ++ "'"-- ++ show ns |
151 else |
156 else |
152 return . text . snd . fromJust $ v |
157 return . text . fst . snd . fromJust $ v |
153 |
158 |
|
159 id2CTyped :: BaseType -> Identifier -> State RenderState Doc |
|
160 id2CTyped BTUnknown i = error $ show i |
|
161 id2CTyped bt (Identifier i _) = id2C True (Identifier i bt) |
154 |
162 |
155 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc |
163 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc |
156 tvar2C _ (FunctionDeclaration name returnType params Nothing) = do |
164 tvar2C _ (FunctionDeclaration name returnType params Nothing) = do |
157 t <- type2C returnType |
165 t <- type2C returnType |
158 p <- liftM hcat $ mapM (tvar2C False) params |
166 p <- liftM hcat $ mapM (tvar2C False) params |
175 where |
183 where |
176 phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p |
184 phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p |
177 phrase2C' p = phrase2C p |
185 phrase2C' p = phrase2C p |
178 |
186 |
179 tvar2C False (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
187 tvar2C False (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
180 tvar2C _ (TypeDeclaration i' t) = do |
188 |
|
189 tvar2C _ td@(TypeDeclaration i' t) = do |
181 tp <- type2C t |
190 tp <- type2C t |
182 i <- id2C True i' |
191 i <- id2CTyped (type2BaseType t) i' |
183 return $ text "type" <+> i <+> tp <> text ";" |
192 return $ text "type" <+> i <+> tp <> text ";" |
184 |
193 |
185 tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do |
194 tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do |
186 t' <- type2C t |
195 t' <- type2C t |
187 i <- mapM (id2C True) ids |
196 i <- mapM (id2CTyped (type2BaseType t)) ids |
188 ie <- initExpr mInitExpr |
197 ie <- initExpr mInitExpr |
189 return $ if isConst then text "const" else empty |
198 return $ if isConst then text "const" else empty |
190 <+> t' |
199 <+> t' |
191 <+> (hsep . punctuate (char ',') $ i) |
200 <+> (hsep . punctuate (char ',') $ i) |
192 <+> ie |
201 <+> ie |
194 where |
203 where |
195 initExpr Nothing = return $ empty |
204 initExpr Nothing = return $ empty |
196 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
205 initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e) |
197 |
206 |
198 tvar2C f (OperatorDeclaration op _ ret params body) = |
207 tvar2C f (OperatorDeclaration op _ ret params body) = |
199 tvar2C f (FunctionDeclaration (Identifier ("<op " ++ op ++ ">") Unknown) ret params body) |
208 tvar2C f (FunctionDeclaration (Identifier ("<op " ++ op ++ ">") BTUnknown) ret params body) |
200 |
209 |
201 |
210 |
202 initExpr2C :: InitExpression -> State RenderState Doc |
211 initExpr2C :: InitExpression -> State RenderState Doc |
203 initExpr2C (InitBinOp op expr1 expr2) = do |
212 initExpr2C (InitBinOp op expr1 expr2) = do |
204 e1 <- initExpr2C expr1 |
213 e1 <- initExpr2C expr1 |