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 type RenderState = [(String, String)] |
20 data RenderState = RenderState |
|
21 { |
|
22 currentScope :: [(String, String)], |
|
23 namespaces :: Map.Map String [(String, String)] |
|
24 } |
21 |
25 |
22 pas2C :: String -> IO () |
26 pas2C :: String -> IO () |
23 pas2C fn = do |
27 pas2C fn = do |
24 setCurrentDirectory "../hedgewars/" |
28 setCurrentDirectory "../hedgewars/" |
25 s <- flip execStateT initState $ f fn |
29 s <- flip execStateT initState $ f fn |
55 |
59 |
56 |
60 |
57 renderCFiles :: Map.Map String PascalUnit -> IO () |
61 renderCFiles :: Map.Map String PascalUnit -> IO () |
58 renderCFiles units = do |
62 renderCFiles units = do |
59 let u = Map.toList units |
63 let u = Map.toList units |
60 mapM_ toCFiles u |
64 let ns = Map.map toNamespace units |
61 |
65 mapM_ (toCFiles ns) u |
62 toCFiles :: (String, PascalUnit) -> IO () |
66 where |
63 toCFiles (_, System _) = return () |
67 toNamespace :: PascalUnit -> [(String, String)] |
64 toCFiles p@(fn, pu) = do |
68 toNamespace = concatMap tv2id . extractTVs |
|
69 extractTVs (System tv) = tv |
|
70 extractTVs (Program {}) = [] |
|
71 extractTVs (Unit _ (Interface _ (TypesAndVars tv)) _ _ _) = tv |
|
72 tv2id :: TypeVarDeclaration -> [(String, String)] |
|
73 tv2id (TypeDeclaration (Identifier i _) _) = [(map toLower i, i)] |
|
74 tv2id (VarDeclaration _ (ids, _) _) = map (\(Identifier i _) -> (map toLower i, i)) ids |
|
75 tv2id (FunctionDeclaration (Identifier i _) _ _ _) = [(map toLower i, i)] |
|
76 tv2id (OperatorDeclaration i _ _ _ _) = [(map toLower i, i)] |
|
77 |
|
78 |
|
79 toCFiles :: Map.Map String [(String, String)] -> (String, PascalUnit) -> IO () |
|
80 toCFiles _ (_, System _) = return () |
|
81 toCFiles ns p@(fn, pu) = do |
65 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
82 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
66 toCFiles' p |
83 toCFiles' p |
67 where |
84 where |
68 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C . pascal2C) p |
85 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C (RenderState [] ns) . pascal2C) p |
69 toCFiles' (fn, (Unit _ interface implementation _ _)) = do |
86 toCFiles' (fn, (Unit _ interface implementation _ _)) = do |
70 writeFile (fn ++ ".h") $ "#pragma once\n" ++ (render2C . interface2C $ interface) |
87 let (a, s) = runState (interface2C interface) (RenderState [] ns) |
71 writeFile (fn ++ ".c") $ (render2C . implementation2C) implementation |
88 writeFile (fn ++ ".h") $ "#pragma once\n" ++ (render a) |
72 |
89 writeFile (fn ++ ".c") $ (render2C s . implementation2C) implementation |
73 render2C = render . flip evalState [] |
90 |
|
91 render2C :: RenderState -> State RenderState Doc -> String |
|
92 render2C a = render . flip evalState a |
74 |
93 |
75 usesFiles :: PascalUnit -> [String] |
94 usesFiles :: PascalUnit -> [String] |
76 usesFiles (Program _ (Implementation uses _) _) = "pas2cSystem" : uses2List uses |
95 usesFiles (Program _ (Implementation uses _) _) = "pas2cSystem" : uses2List uses |
77 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = "pas2cSystem" : uses2List uses1 ++ uses2List uses2 |
96 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = "pas2cSystem" : uses2List uses1 ++ uses2List uses2 |
78 usesFiles (System {}) = [] |
97 usesFiles (System {}) = [] |
99 |
118 |
100 typesAndVars2C :: Bool -> TypesAndVars -> State RenderState Doc |
119 typesAndVars2C :: Bool -> TypesAndVars -> State RenderState Doc |
101 typesAndVars2C b (TypesAndVars ts) = liftM vcat $ mapM (tvar2C b) ts |
120 typesAndVars2C b (TypesAndVars ts) = liftM vcat $ mapM (tvar2C b) ts |
102 |
121 |
103 uses2C :: Uses -> State RenderState Doc |
122 uses2C :: Uses -> State RenderState Doc |
104 uses2C uses = return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
123 uses2C uses@(Uses unitIds) = do |
|
124 mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds) |
|
125 return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
|
126 where |
|
127 injectNamespace (Identifier i _) = do |
|
128 getNS <- gets (flip Map.lookup . namespaces) |
|
129 let f = flip (foldl (\a b -> b:a)) (fromMaybe [] (getNS i)) |
|
130 modify (\s -> s{currentScope = f $ currentScope s}) |
105 |
131 |
106 uses2List :: Uses -> [String] |
132 uses2List :: Uses -> [String] |
107 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
133 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
108 |
134 |
109 |
135 |
110 id2C :: Bool -> Identifier -> State RenderState Doc |
136 id2C :: Bool -> Identifier -> State RenderState Doc |
111 id2C True (Identifier i _) = do |
137 id2C True (Identifier i _) = do |
112 modify (\s -> (map toLower i, i) : s) |
138 modify (\s -> s{currentScope = (map toLower i, i) : currentScope s}) |
113 return $ text i |
139 return $ text i |
114 id2C False (Identifier i _) = do |
140 id2C False (Identifier i _) = do |
115 let i' = map toLower i |
141 let i' = map toLower i |
116 v <- gets $ find (\(a, _) -> a == i') |
142 v <- gets $ find (\(a, _) -> a == i') . currentScope |
|
143 --ns <- gets currentScope |
117 if isNothing v then |
144 if isNothing v then |
118 error $ "Not defined: " ++ i' |
145 error $ "Not defined: '" ++ i' ++ "'"-- ++ show ns |
119 else |
146 else |
120 return . text . snd . fromJust $ v |
147 return . text . snd . fromJust $ v |
121 |
148 |
122 |
149 |
123 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc |
150 tvar2C :: Bool -> TypeVarDeclaration -> State RenderState Doc |
141 text "}" |
168 text "}" |
142 where |
169 where |
143 phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p |
170 phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p |
144 phrase2C' p = phrase2C p |
171 phrase2C' p = phrase2C p |
145 tvar2C False (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
172 tvar2C False (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
146 tvar2C _ (TypeDeclaration (Identifier i _) t) = do |
173 tvar2C _ (TypeDeclaration i' t) = do |
147 tp <- type2C t |
174 tp <- type2C t |
148 return $ text "type" <+> text i <+> tp <> text ";" |
175 i <- id2C True i' |
|
176 return $ text "type" <+> i <+> tp <> text ";" |
149 tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do |
177 tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = do |
150 t' <- type2C t |
178 t' <- type2C t |
151 i <- mapM (id2C True) ids |
179 i <- mapM (id2C True) ids |
152 ie <- initExpr mInitExpr |
180 ie <- initExpr mInitExpr |
153 return $ if isConst then text "const" else empty |
181 return $ if isConst then text "const" else empty |