Fix enum cross-compilation support
[hsc2hs.git] / C.hs
1 {-# LANGUAGE CPP #-}
2 module C where
3
4 {-
5 The standard mode for hsc2hs: generates a C file which is
6 compiled and run; the output of that program is the .hs file.
7 -}
8
9 import Data.Char ( isSpace, intToDigit, ord )
10 import Data.List ( intersperse )
11 import HSCParser ( SourcePos(..), Token(..) )
12
13 import Common
14
15 outFlagHeaderCProg :: Flag -> String
16 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
17 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
18 outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n"
19 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
20 outFlagHeaderCProg _ = ""
21
22 outHeaderCProg :: (SourcePos, String, String) -> String
23 outHeaderCProg (pos, key, arg) = case key of
24 "include" -> outCLine pos++"#include "++arg++"\n"
25 "define" -> outCLine pos++"#define "++arg++"\n"
26 "undef" -> outCLine pos++"#undef "++arg++"\n"
27 "def" -> case arg of
28 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
29 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
30 _ -> ""
31 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
32 "let" -> case break (== '=') arg of
33 (_, "") -> ""
34 (header, _:body) -> case break isSpace header of
35 (name, args) ->
36 outCLine pos++
37 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
38 "printf ("++joinLines body++");\n"
39 _ -> ""
40 where
41 joinLines = concat . intersperse " \\\n" . lines
42
43 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
44 outHeaderHs flags inH toks =
45 "#if " ++
46 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
47 " printf (\"{-# OPTIONS -optc-D" ++
48 "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
49 "__GLASGOW_HASKELL__);\n" ++
50 "#endif\n"++
51 case inH of
52 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
53 Just f -> outInclude ("\""++f++"\"")
54 where
55 outFlag (Include f) = outInclude f
56 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
57 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
58 outFlag _ = ""
59 outSpecial (pos, key, arg) = case key of
60 "include" -> outInclude arg
61 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
62 | otherwise -> ""
63 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
64 _ -> ""
65 goodForOptD arg = case arg of
66 "" -> True
67 c:_ | isSpace c -> True
68 '(':_ -> False
69 _:s -> goodForOptD s
70 toOptD arg = case break isSpace arg of
71 (name, "") -> name
72 (name, _:value) -> name++'=':dropWhile isSpace value
73 outOption s =
74 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
75 " printf (\"{-# OPTIONS %s #-}\\n\", \""++
76 showCString s++"\");\n"++
77 "#else\n"++
78 " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
79 showCString s++"\");\n"++
80 "#endif\n"
81 outInclude s =
82 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
83 " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++
84 showCString s++"\");\n"++
85 "#elif __GLASGOW_HASKELL__ < 610\n"++
86 " printf (\"{-# INCLUDE %s #-}\\n\", \""++
87 showCString s++"\");\n"++
88 "#endif\n"
89
90 outTokenHs :: Token -> String
91 outTokenHs (Text pos txt) =
92 case break (== '\n') txt of
93 (allTxt, []) -> outText allTxt
94 (first, _:rest) ->
95 outText (first++"\n")++
96 outHsLine pos++
97 outText rest
98 where
99 outText s = " fputs (\""++showCString s++"\", stdout);\n"
100 outTokenHs (Special pos key arg) =
101 case key of
102 "include" -> ""
103 "define" -> ""
104 "undef" -> ""
105 "def" -> ""
106 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
107 "let" -> ""
108 "enum" -> outCLine pos++outEnum arg
109 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
110
111 parseEnum :: String -> Maybe (String,String,[(Maybe String,String)])
112 parseEnum arg =
113 case break (== ',') arg of
114 (_, []) -> Nothing
115 (t, _:afterT) -> case break (== ',') afterT of
116 (f, afterF) -> let
117 enums [] = []
118 enums (_:s) = case break (== ',') s of
119 (enum, rest) -> let
120 this = case break (== '=') $ dropWhile isSpace enum of
121 (name, []) -> (Nothing, name)
122 (hsName, _:cName) -> (Just hsName, cName)
123 in this:enums rest
124 in Just (t, f, enums afterF)
125
126 outEnum :: String -> String
127 outEnum arg = case parseEnum arg of
128 Nothing -> ""
129 Just (t,f,enums) ->
130 flip concatMap enums $ \(maybeHsName, cName) ->
131 case maybeHsName of
132 Nothing ->
133 " hsc_enum ("++t++", "++f++", " ++
134 "hsc_haskellize (\""++cName++"\"), "++
135 cName++");\n"
136 Just hsName ->
137 " hsc_enum ("++t++", "++f++", " ++
138 "printf (\"%s\", \""++hsName++"\"), "++
139 cName++");\n"
140
141 outFlagH :: Flag -> String
142 outFlagH (Include f) = "#include "++f++"\n"
143 outFlagH (Define n Nothing) = "#define "++n++" 1\n"
144 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
145 outFlagH _ = ""
146
147 outTokenH :: (SourcePos, String, String) -> String
148 outTokenH (pos, key, arg) =
149 case key of
150 "include" -> outCLine pos++"#include "++arg++"\n"
151 "define" -> outCLine pos++"#define " ++arg++"\n"
152 "undef" -> outCLine pos++"#undef " ++arg++"\n"
153 "def" -> outCLine pos++case arg of
154 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
155 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
156 'i':'n':'l':'i':'n':'e':' ':_ ->
157 "#ifdef __GNUC__\n" ++
158 "extern\n" ++
159 "#endif\n"++
160 arg++"\n"
161 _ -> "extern "++header++";\n"
162 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
163 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
164 _ -> ""
165
166 outTokenC :: (SourcePos, String, String) -> String
167 outTokenC (pos, key, arg) =
168 case key of
169 "def" -> case arg of
170 's':'t':'r':'u':'c':'t':' ':_ -> ""
171 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
172 'i':'n':'l':'i':'n':'e':' ':arg' ->
173 case span (\c -> c /= '{' && c /= '=') arg' of
174 (header, body) ->
175 outCLine pos++
176 "#ifndef __GNUC__\n" ++
177 "extern inline\n" ++
178 "#endif\n"++
179 header++
180 "\n#ifndef __GNUC__\n" ++
181 ";\n" ++
182 "#else\n"++
183 body++
184 "\n#endif\n"
185 _ -> outCLine pos++arg++"\n"
186 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
187 _ -> ""
188
189 conditional :: String -> Bool
190 conditional "if" = True
191 conditional "ifdef" = True
192 conditional "ifndef" = True
193 conditional "elif" = True
194 conditional "else" = True
195 conditional "endif" = True
196 conditional "error" = True
197 conditional "warning" = True
198 conditional _ = False
199
200 outCLine :: SourcePos -> String
201 outCLine (SourcePos name line) =
202 "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
203
204 outHsLine :: SourcePos -> String
205 outHsLine (SourcePos name line) =
206 " hsc_line ("++show (line + 1)++", \""++
207 showCString name++"\");\n"
208
209 showCString :: String -> String
210 showCString = concatMap showCChar
211 where
212 showCChar '\"' = "\\\""
213 showCChar '\'' = "\\\'"
214 showCChar '?' = "\\?"
215 showCChar '\\' = "\\\\"
216 showCChar c | c >= ' ' && c <= '~' = [c]
217 showCChar '\a' = "\\a"
218 showCChar '\b' = "\\b"
219 showCChar '\f' = "\\f"
220 showCChar '\n' = "\\n\"\n \""
221 showCChar '\r' = "\\r"
222 showCChar '\t' = "\\t"
223 showCChar '\v' = "\\v"
224 showCChar c = ['\\',
225 intToDigit (ord c `quot` 64),
226 intToDigit (ord c `quot` 8 `mod` 8),
227 intToDigit (ord c `mod` 8)]
228