54 toCFiles (_, System) = return () |
55 toCFiles (_, System) = return () |
55 toCFiles p@(fn, pu) = do |
56 toCFiles p@(fn, pu) = do |
56 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
57 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
57 toCFiles' p |
58 toCFiles' p |
58 where |
59 where |
59 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render . pascal2C) p |
60 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C . pascal2C) p |
60 toCFiles' (fn, (Unit _ interface implementation _ _)) = do |
61 toCFiles' (fn, (Unit _ interface implementation _ _)) = do |
61 writeFile (fn ++ ".h") $ (render . interface2C) interface |
62 writeFile (fn ++ ".h") $ "#pragma once\n" ++ (render2C . interface2C $ interface) |
62 writeFile (fn ++ ".c") $ (render . implementation2C) implementation |
63 writeFile (fn ++ ".c") $ (render2C . implementation2C) implementation |
63 |
64 |
|
65 system :: [(String, String)] |
|
66 system = [] |
|
67 |
|
68 render2C = render . flip runReader system |
|
69 |
64 usesFiles :: PascalUnit -> [String] |
70 usesFiles :: PascalUnit -> [String] |
65 usesFiles (Program _ (Implementation uses _) _) = uses2List uses |
71 usesFiles (Program _ (Implementation uses _) _) = uses2List uses |
66 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = uses2List uses1 ++ uses2List uses2 |
72 usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = uses2List uses1 ++ uses2List uses2 |
67 |
73 |
68 |
74 |
69 |
75 |
70 pascal2C :: PascalUnit -> Doc |
76 pascal2C :: PascalUnit -> Reader a Doc |
71 pascal2C (Unit _ interface implementation init fin) = |
77 pascal2C (Unit _ interface implementation init fin) = |
72 interface2C interface |
78 liftM2 ($+$) (interface2C interface) (implementation2C implementation) |
73 $+$ |
79 |
74 implementation2C implementation |
80 pascal2C (Program _ implementation mainFunction) = do |
75 pascal2C (Program _ implementation mainFunction) = |
81 impl <- implementation2C implementation |
76 implementation2C implementation |
82 main <- tvar2C True |
77 $+$ |
83 (FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [] (Just (TypesAndVars [], mainFunction))) |
78 tvar2C True (FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [] (Just (TypesAndVars [], mainFunction))) |
84 return $ impl $+$ main |
|
85 |
79 |
86 |
80 |
87 |
81 interface2C :: Interface -> Doc |
88 interface2C :: Interface -> Reader a Doc |
82 interface2C (Interface uses tvars) = uses2C uses $+$ typesAndVars2C True tvars |
89 interface2C (Interface uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars) |
83 |
90 |
84 implementation2C :: Implementation -> Doc |
91 implementation2C :: Implementation -> Reader a Doc |
85 implementation2C (Implementation uses tvars) = uses2C uses $+$ typesAndVars2C True tvars |
92 implementation2C (Implementation uses tvars) = liftM2 ($+$) (uses2C uses) (typesAndVars2C True tvars) |
86 |
93 |
87 |
94 |
88 typesAndVars2C :: Bool -> TypesAndVars -> Doc |
95 typesAndVars2C :: Bool -> TypesAndVars -> Reader a Doc |
89 typesAndVars2C b (TypesAndVars ts) = vcat $ map (tvar2C b) ts |
96 typesAndVars2C b (TypesAndVars ts) = liftM vcat $ mapM (tvar2C b) ts |
90 |
97 |
91 uses2C :: Uses -> Doc |
98 uses2C :: Uses -> Reader a Doc |
92 uses2C uses = vcat $ map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
99 uses2C uses = return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses |
93 |
100 |
94 uses2List :: Uses -> [String] |
101 uses2List :: Uses -> [String] |
95 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
102 uses2List (Uses ids) = map (\(Identifier i _) -> i) ids |
96 |
103 |
97 tvar2C :: Bool -> TypeVarDeclaration -> Doc |
104 tvar2C :: Bool -> TypeVarDeclaration -> Reader a Doc |
98 tvar2C _ (FunctionDeclaration (Identifier name _) returnType params Nothing) = |
105 tvar2C _ (FunctionDeclaration (Identifier name _) returnType params Nothing) = do |
99 type2C returnType <+> text name <> parens (hcat $ map (tvar2C False) params) <> text ";" |
106 t <- type2C returnType |
100 tvar2C True (FunctionDeclaration (Identifier name _) returnType params (Just (tvars, phrase))) = |
107 p <- liftM hcat $ mapM (tvar2C False) params |
101 type2C returnType <+> text name <> parens (hcat $ map (tvar2C False) params) |
108 return $ t <+> text name <> parens p <> text ";" |
102 $+$ |
109 tvar2C True (FunctionDeclaration (Identifier name _) returnType params (Just (tvars, phrase))) = do |
103 text "{" |
110 t <- type2C returnType |
104 $+$ nest 4 ( |
111 p <- liftM hcat $ mapM (tvar2C False) params |
105 typesAndVars2C False tvars |
112 ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase) |
|
113 return $ |
|
114 t <+> text name <> parens p |
106 $+$ |
115 $+$ |
107 phrase2C' phrase |
116 text "{" |
108 ) |
117 $+$ |
109 $+$ |
118 nest 4 ph |
110 text "}" |
119 $+$ |
111 where |
120 text "}" |
112 phrase2C' (Phrases p) = vcat $ map phrase2C p |
121 where |
|
122 phrase2C' (Phrases p) = liftM vcat $ mapM phrase2C p |
113 phrase2C' p = phrase2C p |
123 phrase2C' p = phrase2C p |
114 tvar2C False (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
124 tvar2C False (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name |
115 tvar2C _ (TypeDeclaration (Identifier i _) t) = text "type" <+> text i <+> type2C t <> text ";" |
125 tvar2C _ (TypeDeclaration (Identifier i _) t) = do |
|
126 tp <- type2C t |
|
127 return $ text "type" <+> text i <+> tp <> text ";" |
116 tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = |
128 tvar2C _ (VarDeclaration isConst (ids, t) mInitExpr) = |
117 if isConst then text "const" else empty |
129 if isConst then text "const" else empty |
118 <+> |
130 <+> |
119 type2C t |
131 type2C t |
120 <+> |
132 <+> |
127 initExpr Nothing = empty |
139 initExpr Nothing = empty |
128 initExpr (Just e) = text "=" <+> initExpr2C e |
140 initExpr (Just e) = text "=" <+> initExpr2C e |
129 tvar2C f (OperatorDeclaration op _ ret params body) = |
141 tvar2C f (OperatorDeclaration op _ ret params body) = |
130 tvar2C f (FunctionDeclaration (Identifier ("<op " ++ op ++ ">") Unknown) ret params body) |
142 tvar2C f (FunctionDeclaration (Identifier ("<op " ++ op ++ ">") Unknown) ret params body) |
131 |
143 |
132 initExpr2C :: InitExpression -> Doc |
144 initExpr2C :: InitExpression -> Reader a Doc |
133 initExpr2C (InitBinOp op expr1 expr2) = parens $ (initExpr2C expr1) <+> op2C op <+> (initExpr2C expr2) |
145 initExpr2C (InitBinOp op expr1 expr2) = parens $ (initExpr2C expr1) <+> op2C op <+> (initExpr2C expr2) |
134 initExpr2C (InitNumber s) = text s |
146 initExpr2C (InitNumber s) = text s |
135 initExpr2C (InitFloat s) = text s |
147 initExpr2C (InitFloat s) = text s |
136 initExpr2C (InitHexNumber s) = text "0x" <> (text . map toLower $ s) |
148 initExpr2C (InitHexNumber s) = text "0x" <> (text . map toLower $ s) |
137 initExpr2C (InitString s) = doubleQuotes $ text s |
149 initExpr2C (InitString s) = doubleQuotes $ text s |
138 initExpr2C (InitReference (Identifier i _)) = text i |
150 initExpr2C (InitReference (Identifier i _)) = text i |
139 |
151 |
140 |
152 |
141 initExpr2C _ = text "<<expression>>" |
153 initExpr2C _ = text "<<expression>>" |
142 |
154 |
143 type2C :: TypeDecl -> Doc |
155 type2C :: TypeDecl -> Reader a Doc |
144 type2C UnknownType = text "void" |
156 type2C UnknownType = text "void" |
145 type2C (String l) = text $ "string" ++ show l |
157 type2C (String l) = text $ "string" ++ show l |
146 type2C (SimpleType (Identifier i _)) = text i |
158 type2C (SimpleType (Identifier i _)) = text i |
147 type2C (PointerTo t) = type2C t <> text "*" |
159 type2C (PointerTo t) = type2C t <> text "*" |
148 type2C (RecordType tvs union) = text "{" $+$ (nest 4 . vcat . map (tvar2C False) $ tvs) $+$ text "}" |
160 type2C (RecordType tvs union) = text "{" $+$ (nest 4 . vcat . map (tvar2C False) $ tvs) $+$ text "}" |
150 type2C (Sequence ids) = text "<<sequence type>>" |
162 type2C (Sequence ids) = text "<<sequence type>>" |
151 type2C (ArrayDecl r t) = text "<<array type>>" |
163 type2C (ArrayDecl r t) = text "<<array type>>" |
152 type2C (Set t) = text "<<set>>" |
164 type2C (Set t) = text "<<set>>" |
153 type2C (FunctionType returnType params) = text "<<function>>" |
165 type2C (FunctionType returnType params) = text "<<function>>" |
154 |
166 |
155 phrase2C :: Phrase -> Doc |
167 phrase2C :: Phrase -> Reader a Doc |
156 phrase2C (Phrases p) = text "{" $+$ (nest 4 . vcat . map phrase2C $ p) $+$ text "}" |
168 phrase2C (Phrases p) = text "{" $+$ (nest 4 . vcat . map phrase2C $ p) $+$ text "}" |
157 phrase2C (ProcCall f@(FunCall {}) []) = ref2C f <> semi |
169 phrase2C (ProcCall f@(FunCall {}) []) = ref2C f <> semi |
158 phrase2C (ProcCall ref params) = ref2C ref <> parens (hsep . punctuate (char ',') . map expr2C $ params) <> semi |
170 phrase2C (ProcCall ref params) = ref2C ref <> parens (hsep . punctuate (char ',') . map expr2C $ params) <> semi |
159 phrase2C (IfThenElse (expr) phrase1 mphrase2) = text "if" <> parens (expr2C expr) $+$ (phrase2C . wrapPhrase) phrase1 $+$ elsePart |
171 phrase2C (IfThenElse (expr) phrase1 mphrase2) = text "if" <> parens (expr2C expr) $+$ (phrase2C . wrapPhrase) phrase1 $+$ elsePart |
160 where |
172 where |
191 expr2C Null = text "NULL" |
203 expr2C Null = text "NULL" |
192 expr2C (BuiltInFunCall params ref) = ref2C ref <> parens (hsep . punctuate (char ',') . map expr2C $ params) |
204 expr2C (BuiltInFunCall params ref) = ref2C ref <> parens (hsep . punctuate (char ',') . map expr2C $ params) |
193 expr2C _ = text "<<expression>>" |
205 expr2C _ = text "<<expression>>" |
194 |
206 |
195 |
207 |
196 ref2C :: Reference -> Doc |
208 ref2C :: Reference -> Reader a Doc |
197 ref2C (ArrayElement exprs ref) = ref2C ref <> (brackets . hcat) (punctuate comma $ map expr2C exprs) |
209 ref2C (ArrayElement exprs ref) = ref2C ref <> (brackets . hcat) (punctuate comma $ map expr2C exprs) |
198 ref2C (SimpleReference (Identifier name _)) = text name |
210 ref2C (SimpleReference (Identifier name _)) = text name |
199 ref2C (RecordField (Dereference ref1) ref2) = ref2C ref1 <> text "->" <> ref2C ref2 |
211 ref2C (RecordField (Dereference ref1) ref2) = ref2C ref1 <> text "->" <> ref2C ref2 |
200 ref2C (RecordField ref1 ref2) = ref2C ref1 <> text "." <> ref2C ref2 |
212 ref2C (RecordField ref1 ref2) = ref2C ref1 <> text "." <> ref2C ref2 |
201 ref2C (Dereference ref) = parens $ text "*" <> ref2C ref |
213 ref2C (Dereference ref) = parens $ text "*" <> ref2C ref |