Add source repository stanza to cabal file
[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 :: Token -> String
72 outTokenHs (Text pos txt) =
73 case break (== '\n') txt of
74 (allTxt, []) -> outText allTxt
75 (first, _:rest) ->
76 outText (first++"\n")++
77 outHsLine pos++
78 outText rest
79 where
80 outText s = " hsc_fputs (\""++showCString s++"\", hsc_stdout());\n"
81 outTokenHs (Special pos key arg) =
82 case key of
83 "include" -> ""
84 "define" -> ""
85 "undef" -> ""
86 "def" -> ""
87 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
88 "let" -> ""
89 "enum" -> outCLine pos++outEnum arg
90 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
91
92 parseEnum :: String -> Maybe (String,String,[(Maybe String,String)])
93 parseEnum arg =
94 case break (== ',') arg of
95 (_, []) -> Nothing
96 (t, _:afterT) -> case break (== ',') afterT of
97 (f, afterF) -> let
98 enums [] = []
99 enums (_:s) = case break (== ',') s of
100 (enum, rest) -> let
101 this = case break (== '=') $ dropWhile isSpace enum of
102 (name, []) -> (Nothing, name)
103 (hsName, _:cName) -> (Just hsName, cName)
104 in this:enums rest
105 in Just (t, f, enums afterF)
106
107 outEnum :: String -> String
108 outEnum arg = case parseEnum arg of
109 Nothing -> ""
110 Just (t,f,enums) ->
111 flip concatMap enums $ \(maybeHsName, cName) ->
112 case maybeHsName of
113 Nothing ->
114 " hsc_enum ("++t++", "++f++", " ++
115 "hsc_haskellize (\""++cName++"\"), "++
116 cName++");\n"
117 Just hsName ->
118 " hsc_enum ("++t++", "++f++", " ++
119 "hsc_printf (\"%s\", \""++hsName++"\"), "++
120 cName++");\n"
121
122 outFlagH :: Flag -> String
123 outFlagH (Include f) = "#include "++f++"\n"
124 outFlagH (Define n Nothing) = "#define "++n++" 1\n"
125 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
126 outFlagH _ = ""
127
128 outTokenH :: (SourcePos, String, String) -> String
129 outTokenH (pos, key, arg) =
130 case key of
131 "include" -> outCLine pos++"#include "++arg++"\n"
132 "define" -> outCLine pos++"#define " ++arg++"\n"
133 "undef" -> outCLine pos++"#undef " ++arg++"\n"
134 "def" -> outCLine pos++case arg of
135 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
136 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
137 'i':'n':'l':'i':'n':'e':' ':_ ->
138 "#ifdef __GNUC__\n" ++
139 "extern\n" ++
140 "#endif\n"++
141 arg++"\n"
142 _ -> "extern "++header++";\n"
143 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
144 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
145 _ -> ""
146
147 outTokenC :: (SourcePos, String, String) -> String
148 outTokenC (pos, key, arg) =
149 case key of
150 "def" -> case arg of
151 's':'t':'r':'u':'c':'t':' ':_ -> ""
152 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
153 'i':'n':'l':'i':'n':'e':' ':arg' ->
154 case span (\c -> c /= '{' && c /= '=') arg' of
155 (header, body) ->
156 outCLine pos++
157 "#ifndef __GNUC__\n" ++
158 "extern inline\n" ++
159 "#endif\n"++
160 header++
161 "\n#ifndef __GNUC__\n" ++
162 ";\n" ++
163 "#else\n"++
164 body++
165 "\n#endif\n"
166 _ -> outCLine pos++arg++"\n"
167 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
168 _ -> ""
169
170 conditional :: String -> Bool
171 conditional "if" = True
172 conditional "ifdef" = True
173 conditional "ifndef" = True
174 conditional "elif" = True
175 conditional "else" = True
176 conditional "endif" = True
177 conditional "error" = True
178 conditional "warning" = True
179 conditional _ = False
180
181 outCLine :: SourcePos -> String
182 outCLine (SourcePos name line) =
183 "#line "++show line++" \""++showCString (snd (splitFileName name))++"\"\n"
184
185 outHsLine :: SourcePos -> String
186 outHsLine (SourcePos name line) =
187 " hsc_line ("++show (line + 1)++", \""++
188 (showCString . showCString) name ++ "\");\n"
189
190 showCString :: String -> String
191 showCString = concatMap showCChar
192 where
193 showCChar '\"' = "\\\""
194 showCChar '\'' = "\\\'"
195 showCChar '?' = "\\?"
196 showCChar '\\' = "\\\\"
197 showCChar c | c >= ' ' && c <= '~' = [c]
198 showCChar '\a' = "\\a"
199 showCChar '\b' = "\\b"
200 showCChar '\f' = "\\f"
201 showCChar '\n' = "\\n\"\n \""
202 showCChar '\r' = "\\r"
203 showCChar '\t' = "\\t"
204 showCChar '\v' = "\\v"
205 showCChar c = ['\\',
206 intToDigit (ord c `quot` 64),
207 intToDigit (ord c `quot` 8 `mod` 8),
208 intToDigit (ord c `mod` 8)]