92 $ gets stringConsts |
92 $ gets stringConsts |
93 |
93 |
94 docToLower :: Doc -> Doc |
94 docToLower :: Doc -> Doc |
95 docToLower = text . map toLower . render |
95 docToLower = text . map toLower . render |
96 |
96 |
97 pas2C :: String -> IO () |
97 pas2C :: String -> String -> String -> IO () |
98 pas2C fn = do |
98 pas2C fn inputPath outputPath = do |
99 setCurrentDirectory "../hedgewars/" |
99 setCurrentDirectory inputPath |
100 s <- flip execStateT initState $ f fn |
100 s <- flip execStateT initState $ f fn |
101 renderCFiles s |
101 renderCFiles s outputPath |
102 where |
102 where |
103 printLn = liftIO . hPutStrLn stdout |
103 printLn = liftIO . hPutStrLn stdout |
104 print = liftIO . hPutStr stdout |
104 print = liftIO . hPutStr stdout |
105 initState = Map.empty |
105 initState = Map.empty |
106 f :: String -> StateT (Map.Map String PascalUnit) IO () |
106 f :: String -> StateT (Map.Map String PascalUnit) IO () |
118 (Right fc) -> do |
118 (Right fc) -> do |
119 print "ok, parsing... " |
119 print "ok, parsing... " |
120 let ptree = parse pascalUnit fileName fc |
120 let ptree = parse pascalUnit fileName fc |
121 case ptree of |
121 case ptree of |
122 (Left a) -> do |
122 (Left a) -> do |
123 liftIO $ writeFile "preprocess.out" fc |
123 liftIO $ writeFile (outputPath ++ "preprocess.out") fc |
124 printLn $ show a ++ "\nsee preprocess.out for preprocessed source" |
124 printLn $ show a ++ "\nsee preprocess.out for preprocessed source" |
125 fail "stop" |
125 fail "stop" |
126 (Right a) -> do |
126 (Right a) -> do |
127 printLn "ok" |
127 printLn "ok" |
128 modify (Map.insert fileName a) |
128 modify (Map.insert fileName a) |
129 mapM_ f (usesFiles a) |
129 mapM_ f (usesFiles a) |
130 |
130 |
131 |
131 |
132 renderCFiles :: Map.Map String PascalUnit -> IO () |
132 renderCFiles :: Map.Map String PascalUnit -> String -> IO () |
133 renderCFiles units = do |
133 renderCFiles units outputPath = do |
134 let u = Map.toList units |
134 let u = Map.toList units |
135 let nss = Map.map (toNamespace nss) units |
135 let nss = Map.map (toNamespace nss) units |
136 --hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . Map.null) $ nss) |
136 --hPutStrLn stderr $ "Units: " ++ (show . Map.keys . Map.filter (not . Map.null) $ nss) |
137 --writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss |
137 --writeFile "pas2c.log" $ unlines . map (\t -> show (fst t) ++ "\n" ++ (unlines . map ((:) '\t' . show) . snd $ t)) . Map.toList $ nss |
138 mapM_ (toCFiles nss) u |
138 mapM_ (toCFiles outputPath nss) u |
139 where |
139 where |
140 toNamespace :: Map.Map String Records -> PascalUnit -> Records |
140 toNamespace :: Map.Map String Records -> PascalUnit -> Records |
141 toNamespace nss (System tvs) = |
141 toNamespace nss (System tvs) = |
142 currentScope $ execState f (emptyState nss) |
142 currentScope $ execState f (emptyState nss) |
143 where |
143 where |
177 where |
177 where |
178 f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""} |
178 f st = st{currentScope = Map.unionWith un records (currentScope st), currentUnit = ""} |
179 records = Map.fromList $ map (\(Record a b d) -> (map toLower a, [Record (prefix ++ a) b d])) recs |
179 records = Map.fromList $ map (\(Record a b d) -> (map toLower a, [Record (prefix ++ a) b d])) recs |
180 un [a] b = a : b |
180 un [a] b = a : b |
181 |
181 |
182 toCFiles :: Map.Map String Records -> (String, PascalUnit) -> IO () |
182 toCFiles :: String -> Map.Map String Records -> (String, PascalUnit) -> IO () |
183 toCFiles _ (_, System _) = return () |
183 toCFiles _ _ (_, System _) = return () |
184 toCFiles _ (_, Redo _) = return () |
184 toCFiles _ _ (_, Redo _) = return () |
185 toCFiles ns p@(fn, pu) = do |
185 toCFiles outputPath ns p@(fn, pu) = do |
186 hPutStrLn stdout $ "Rendering '" ++ fn ++ "'..." |
186 hPutStrLn stdout $ "Rendering '" ++ fn ++ "'..." |
187 toCFiles' p |
187 toCFiles' p |
188 where |
188 where |
189 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p |
189 toCFiles' (fn, p@(Program {})) = writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p |
190 toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do |
190 toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do |
191 let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"} |
191 let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"} |
192 (a', s') = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"} |
192 (a', s') = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"} |
193 writeFile (fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) |
193 writeFile (outputPath ++ fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text "")) |
194 writeFile (fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation |
194 writeFile (outputPath ++ fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation |
195 initialState = emptyState ns |
195 initialState = emptyState ns |
196 |
196 |
197 render2C :: RenderState -> State RenderState Doc -> String |
197 render2C :: RenderState -> State RenderState Doc -> String |
198 render2C a = render . ($+$ empty) . flip evalState a |
198 render2C a = render . ($+$ empty) . flip evalState a |
199 |
199 |