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