Bump version to 0.68.2 and prepare for release
[hsc2hs.git] / C.hs
1 module C where
2
3 {-
4 The standard mode for hsc2hs: generates a C file which is
5 compiled and run; the output of that program is the .hs file.
6 -}
7
8 import Data.Char ( isSpace, intToDigit, ord )
9 import Data.List ( intersperse )
10 import System.FilePath ( splitFileName )
11
12 import HSCParser ( SourcePos(..), Token(..) )
13 import Flags
14
15 outTemplateHeaderCProg :: FilePath -> String
16 outTemplateHeaderCProg template = "#include \"" ++ template ++ "\"\n"
17
18 outFlagHeaderCProg :: Flag -> String
19 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
20 outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n"
21 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
22 outFlagHeaderCProg _ = ""
23
24 outHeaderCProg :: (SourcePos, String, String) -> String
25 outHeaderCProg (pos, key, arg) = case key of
26 "include" -> outCLine pos++"#include "++arg++"\n"
27 "define" -> outCLine pos++"#define "++arg++"\n"
28 "undef" -> outCLine pos++"#undef "++arg++"\n"
29 "def" -> case arg of
30 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
31 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
32 _ -> ""
33 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
34 "let" -> case break (== '=') arg of
35 (_, "") -> ""
36 (header, _:body) -> case break isSpace header of
37 (name, args) ->
38 outCLine pos++
39 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
40 "hsc_printf ("++joinLines body++");\n"
41 _ -> ""
42 where
43 joinLines = concat . intersperse " \\\n" . lines
44
45 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
46 outHeaderHs flags inH toks =
47 case inH of
48 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
49 Just _ -> ""
50 where
51 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
52 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
53 outFlag _ = ""
54 outSpecial (pos, key, arg) = case key of
55 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
56 | otherwise -> ""
57 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
58 _ -> ""
59 goodForOptD arg = case arg of
60 "" -> True
61 c:_ | isSpace c -> True
62 '(':_ -> False
63 _:s -> goodForOptD s
64 toOptD arg = case break isSpace arg of
65 (name, "") -> name
66 (name, _:value) -> name++'=':dropWhile isSpace value
67 outOption s =
68 " hsc_printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
69 showCString s++"\");\n"
70
71 outTokenHs :: Bool -- ^ enable COLUMN pragmas?
72 -> (ShowS, (Bool, Bool))
73 -> Token
74 -> (ShowS, (Bool, Bool))
75 outTokenHs enableCol (out, state) (Text pos txt) =
76 (out . showString str, state')
77 where
78 (str, state') = outTextHs state pos txt outText outHsLine
79 (if enableCol then outHsColumn else const "")
80 outText s = " hsc_fputs (\""++showCString s++"\", hsc_stdout());\n"
81 outTokenHs _ (out, (rowSync, colSync)) (Special pos key arg) =
82 (out . showString str, (rowSync && null str, colSync && null str))
83 where
84 str = case key of
85 "include" -> ""
86 "define" -> ""
87 "undef" -> ""
88 "def" -> ""
89 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
90 "let" -> ""
91 "enum" -> outCLine pos++outEnum arg
92 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
93
94 -- | Output a 'Text' 'Token' literally, making use of the three given output
95 -- functions. The state contains @(lineSync, colSync)@, which indicate
96 -- whether the line number and column number in the input are synchronized
97 -- with those of the output.
98 outTextHs :: (Bool, Bool) -- ^ state @(lineSync, colSync)@
99 -> SourcePos -- ^ original position of the token
100 -> String -- ^ text of the token
101 -> (String -> String) -- ^ output text
102 -> (SourcePos -> String) -- ^ output LINE pragma
103 -> (Int -> String) -- ^ output COLUMN pragma
104 -> (String, (Bool, Bool))
105 outTextHs (lineSync, colSync) pos@(SourcePos _ _ col) txt
106 outText outLine outColumn =
107 -- Ensure COLUMN pragmas are always inserted right before an identifier.
108 -- They are never inserted in the middle of whitespace, as that could ruin
109 -- the indentation.
110 case break (== '\n') spaces of
111 (_, "") ->
112 case break (== '\n') rest of
113 ("", _) ->
114 ( outText spaces
115 , (lineSync, colSync) )
116 (_, "") ->
117 ( (outText spaces++
118 updateCol++
119 outText rest)
120 , (lineSync, True) )
121 (firstRest, nl:restRest) ->
122 ( (outText spaces++
123 updateCol++
124 outText (firstRest++[nl])++
125 updateLine++
126 outText restRest)
127 , (True, True) )
128 (firstSpaces, nl:restSpaces) ->
129 ( (outText (firstSpaces++[nl])++
130 updateLine++
131 outText (restSpaces++rest))
132 , (True, True) )
133 where
134 (spaces, rest) = span isSpace txt
135 updateLine | lineSync = ""
136 | otherwise = outLine pos
137 updateCol | colSync = ""
138 | otherwise = outColumn (col + length spaces)
139
140 parseEnum :: String -> Maybe (String,String,[(Maybe String,String)])
141 parseEnum arg =
142 case break (== ',') arg of
143 (_, []) -> Nothing
144 (t, _:afterT) -> case break (== ',') afterT of
145 (f, afterF) -> let
146 enums [] = []
147 enums (_:s) = case break (== ',') s of
148 (enum, rest) -> let
149 this = case break (== '=') $ dropWhile isSpace enum of
150 (name, []) -> (Nothing, name)
151 (hsName, _:cName) -> (Just hsName, cName)
152 in this:enums rest
153 in Just (t, f, enums afterF)
154
155 outEnum :: String -> String
156 outEnum arg = case parseEnum arg of
157 Nothing -> ""
158 Just (t,f,enums) ->
159 flip concatMap enums $ \(maybeHsName, cName) ->
160 case maybeHsName of
161 Nothing ->
162 " hsc_enum ("++t++", "++f++", " ++
163 "hsc_haskellize (\""++cName++"\"), "++
164 cName++");\n"
165 Just hsName ->
166 " hsc_enum ("++t++", "++f++", " ++
167 "hsc_printf (\"%s\", \""++hsName++"\"), "++
168 cName++");\n"
169
170 outFlagH :: Flag -> String
171 outFlagH (Include f) = "#include "++f++"\n"
172 outFlagH (Define n Nothing) = "#define "++n++" 1\n"
173 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
174 outFlagH _ = ""
175
176 outTokenH :: (SourcePos, String, String) -> String
177 outTokenH (pos, key, arg) =
178 case key of
179 "include" -> outCLine pos++"#include "++arg++"\n"
180 "define" -> outCLine pos++"#define " ++arg++"\n"
181 "undef" -> outCLine pos++"#undef " ++arg++"\n"
182 "def" -> outCLine pos++case arg of
183 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
184 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
185 'i':'n':'l':'i':'n':'e':' ':_ ->
186 "#ifdef __GNUC__\n" ++
187 "extern\n" ++
188 "#endif\n"++
189 arg++"\n"
190 _ -> "extern "++header++";\n"
191 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
192 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
193 _ -> ""
194
195 outTokenC :: (SourcePos, String, String) -> String
196 outTokenC (pos, key, arg) =
197 case key of
198 "def" -> case arg of
199 's':'t':'r':'u':'c':'t':' ':_ -> ""
200 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
201 'i':'n':'l':'i':'n':'e':' ':arg' ->
202 case span (\c -> c /= '{' && c /= '=') arg' of
203 (header, body) ->
204 outCLine pos++
205 "#ifndef __GNUC__\n" ++
206 "extern inline\n" ++
207 "#endif\n"++
208 header++
209 "\n#ifndef __GNUC__\n" ++
210 ";\n" ++
211 "#else\n"++
212 body++
213 "\n#endif\n"
214 _ -> outCLine pos++arg++"\n"
215 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
216 _ -> ""
217
218 conditional :: String -> Bool
219 conditional "if" = True
220 conditional "ifdef" = True
221 conditional "ifndef" = True
222 conditional "elif" = True
223 conditional "else" = True
224 conditional "endif" = True
225 conditional "error" = True
226 conditional "warning" = True
227 conditional _ = False
228
229 outCLine :: SourcePos -> String
230 outCLine (SourcePos name line _) =
231 "#line "++show line++" \""++showCString (snd (splitFileName name))++"\"\n"
232
233 outHsLine :: SourcePos -> String
234 outHsLine (SourcePos name line _) =
235 " hsc_line ("++show (line + 1)++", \""++
236 (showCString . showCString) name ++ "\");\n"
237
238 outHsColumn :: Int -> String
239 outHsColumn column =
240 " hsc_column ("++show column++");\n"
241
242 showCString :: String -> String
243 showCString = concatMap showCChar
244 where
245 showCChar '\"' = "\\\""
246 showCChar '\'' = "\\\'"
247 showCChar '?' = "\\?"
248 showCChar '\\' = "\\\\"
249 showCChar c | c >= ' ' && c <= '~' = [c]
250 showCChar '\a' = "\\a"
251 showCChar '\b' = "\\b"
252 showCChar '\f' = "\\f"
253 showCChar '\n' = "\\n\"\n \""
254 showCChar '\r' = "\\r"
255 showCChar '\t' = "\\t"
256 showCChar '\v' = "\\v"
257 showCChar c = ['\\',
258 intToDigit (ord c `quot` 64),
259 intToDigit (ord c `quot` 8 `mod` 8),
260 intToDigit (ord c `mod` 8)]