10 import System.Directory |
10 import System.Directory |
11 import Control.Monad.IO.Class |
11 import Control.Monad.IO.Class |
12 import PascalPreprocessor |
12 import PascalPreprocessor |
13 import Control.Exception |
13 import Control.Exception |
14 import System.IO.Error |
14 import System.IO.Error |
15 import qualified Data.Set as Set |
15 import qualified Data.Map as Map |
16 |
16 |
17 |
17 |
18 pas2C :: String -> IO String |
18 pas2C :: String -> IO () |
19 pas2C = flip evalStateT initState . f |
19 pas2C fn = do |
|
20 setCurrentDirectory "../hedgewars/" |
|
21 flip evalStateT initState $ f fn |
20 where |
22 where |
21 printLn = liftIO . hPutStrLn stderr |
23 printLn = liftIO . hPutStrLn stderr |
22 initState = Set.empty |
24 initState = Map.empty |
23 f :: String -> StateT (Set.Set String) IO String |
25 f :: String -> StateT (Map.Map String PascalUnit) IO () |
24 f fileName = do |
26 f fileName = do |
25 liftIO $ setCurrentDirectory "../hedgewars/" |
27 processed <- gets $ Map.member fileName |
26 |
28 unless processed $ do |
27 fc' <- liftIO $ tryJust (guard . isDoesNotExistError) $ preprocess fileName |
29 fc' <- liftIO |
28 case fc' of |
30 $ tryJust (guard . isDoesNotExistError) |
29 (Left a) -> return "" |
31 $ hPutStr stderr ("Preprocessing '" ++ fileName ++ ".pas'... ") >> preprocess (fileName ++ ".pas") |
30 (Right fc) -> do |
32 case fc' of |
31 modify $ Set.insert fileName |
33 (Left a) -> printLn "doesn't exist" |
32 printLn $ "Preprocessed " ++ fileName |
34 (Right fc) -> do |
33 liftIO $ writeFile "debug.txt" fc |
35 printLn "ok" |
34 let ptree = parse pascalUnit fileName fc |
36 let ptree = parse pascalUnit fileName fc |
35 case ptree of |
37 case ptree of |
36 (Left a) -> return (show a) |
38 (Left a) -> do |
37 (Right a) -> (return . render . pascal2C) a |
39 liftIO $ writeFile "preprocess.out" fc |
|
40 printLn $ show a ++ "\nsee preprocess.out for preprocessed source" |
|
41 fail "stop" |
|
42 (Right a) -> do |
|
43 modify (Map.insert fileName a) |
|
44 mapM_ f (usesFiles a) |
|
45 |
38 |
46 |
|
47 usesFiles :: PascalUnit -> [String] |
|
48 usesFiles (Program _ (Implementation uses _) _) = uses2List uses |
|
49 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = uses2List uses1 ++ uses2List uses2 |
|
50 |
|
51 |
|
52 |
39 pascal2C :: PascalUnit -> Doc |
53 pascal2C :: PascalUnit -> Doc |
40 pascal2C (Unit unitName interface implementation init fin) = |
54 pascal2C (Unit unitName interface implementation init fin) = |
41 interface2C interface |
55 interface2C interface |
42 $+$ |
56 $+$ |
43 implementation2C implementation |
57 implementation2C implementation |
44 pascal2C (Program _ implementation mainFunction) = |
58 pascal2C (Program _ implementation mainFunction) = |
45 implementation2C implementation |
59 implementation2C implementation |
46 $+$ |
60 $+$ |
47 tvar2C (FunctionDeclaration (Identifier "main") (SimpleType $ Identifier "int") (Just (TypesAndVars [], mainFunction))) |
61 tvar2C (FunctionDeclaration (Identifier "main") (SimpleType $ Identifier "int") [] (Just (TypesAndVars [], mainFunction))) |
48 interface2C :: Interface -> Doc |
62 interface2C :: Interface -> Doc |
49 interface2C (Interface uses tvars) = typesAndVars2C tvars |
63 interface2C (Interface uses tvars) = uses2C uses $+$ typesAndVars2C tvars |
50 |
64 |
51 implementation2C :: Implementation -> Doc |
65 implementation2C :: Implementation -> Doc |
52 implementation2C (Implementation uses tvars) = typesAndVars2C tvars |
66 implementation2C (Implementation uses tvars) = uses2C uses $+$ typesAndVars2C tvars |
53 |
67 |
54 |
68 |
55 typesAndVars2C :: TypesAndVars -> Doc |
69 typesAndVars2C :: TypesAndVars -> Doc |
56 typesAndVars2C (TypesAndVars ts) = vcat $ map tvar2C ts |
70 typesAndVars2C (TypesAndVars ts) = vcat $ map tvar2C ts |
57 |
71 |
|
72 uses2C :: Uses -> Doc |
|
73 uses2C uses = vcat $ map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
|
74 |
|
75 uses2List :: Uses -> [String] |
|
76 uses2List (Uses ids) = map (\(Identifier i) -> i) ids |
58 |
77 |
59 tvar2C :: TypeVarDeclaration -> Doc |
78 tvar2C :: TypeVarDeclaration -> Doc |
60 tvar2C (FunctionDeclaration (Identifier name) returnType Nothing) = |
79 tvar2C (FunctionDeclaration (Identifier name) returnType params Nothing) = |
61 type2C returnType <+> text (name ++ "();") |
80 type2C returnType <+> text (name ++ "();") |
62 tvar2C (FunctionDeclaration (Identifier name) returnType (Just (tvars, phrase))) = |
81 tvar2C (FunctionDeclaration (Identifier name) returnType params (Just (tvars, phrase))) = |
63 type2C returnType <+> text (name ++ "()") |
82 type2C returnType <+> text (name ++ "()") |
64 $$ |
|
65 text "{" $+$ (nest 4 $ typesAndVars2C tvars) |
|
66 $+$ |
83 $+$ |
67 phrase2C phrase |
84 text "{" |
68 $+$ |
85 $+$ nest 4 ( |
|
86 typesAndVars2C tvars |
|
87 $+$ |
|
88 phrase2C' phrase |
|
89 ) |
|
90 $+$ |
69 text "}" |
91 text "}" |
|
92 where |
|
93 phrase2C' (Phrases p) = vcat $ map phrase2C p |
|
94 phrase2C' p = phrase2C p |
70 tvar2C (TypeDeclaration (Identifier i) t) = text "type" <+> text i <+> type2C t <> text ";" |
95 tvar2C (TypeDeclaration (Identifier i) t) = text "type" <+> text i <+> type2C t <> text ";" |
71 tvar2C (VarDeclaration isConst (ids, t) mInitExpr) = |
96 tvar2C (VarDeclaration isConst (ids, t) mInitExpr) = |
72 if isConst then text "const" else empty |
97 if isConst then text "const" else empty |
73 <+> |
98 <+> |
74 type2C t |
99 type2C t |
96 type2C :: TypeDecl -> Doc |
121 type2C :: TypeDecl -> Doc |
97 type2C UnknownType = text "void" |
122 type2C UnknownType = text "void" |
98 type2C (String l) = text $ "string" ++ show l |
123 type2C (String l) = text $ "string" ++ show l |
99 type2C (SimpleType (Identifier i)) = text i |
124 type2C (SimpleType (Identifier i)) = text i |
100 type2C (PointerTo t) = type2C t <> text "*" |
125 type2C (PointerTo t) = type2C t <> text "*" |
101 type2C (RecordType tvs) = text "{" $+$ (nest 4 . vcat . map tvar2C $ tvs) $+$ text "}" |
126 type2C (RecordType tvs union) = text "{" $+$ (nest 4 . vcat . map tvar2C $ tvs) $+$ text "}" |
102 type2C (RangeType r) = text "<<range type>>" |
127 type2C (RangeType r) = text "<<range type>>" |
103 type2C (Sequence ids) = text "<<sequence type>>" |
128 type2C (Sequence ids) = text "<<sequence type>>" |
104 type2C (ArrayDecl r t) = text "<<array type>>" |
129 type2C (ArrayDecl r t) = text "<<array type>>" |
105 |
130 |
106 |
131 |