YAML kills a kitten again...
[hsc2hs.git] / UtilsCodegen.hs
1 module UtilsCodegen where
2
3 {-
4 Generate the utility code for hsc2hs.
5
6 We don't want to include C headers in template-hsc.h
7 See GHC trac #2897
8 -}
9
10 import Control.Monad
11
12 import C
13 import Common
14 import Flags
15
16 withUtilsObject :: Config -> FilePath -> FilePath
17 -> (FilePath -> IO a)
18 -> IO a
19 withUtilsObject config outDir outBase f = do
20
21 let beVerbose = cVerbose config
22 flags = cFlags config
23 possiblyRemove = if cKeepFiles config
24 then flip const
25 else finallyRemove
26 cUtilsName = outDir ++ outBase ++ "_hsc_utils.c"
27 oUtilsName = outDir ++ outBase ++ "_hsc_utils.o"
28
29 possiblyRemove cUtilsName $ do
30 writeBinaryFile cUtilsName $ unlines $
31 ["#include <stddef.h>",
32 "#include <string.h>",
33 "#include <stdio.h>",
34 "#include <stdarg.h>",
35 "#include <ctype.h>",
36 "",
37 outTemplateHeaderCProg (cTemplate config),
38 "",
39 "int hsc_printf(const char *format, ...) {",
40 " int r;",
41 " va_list argp;",
42 " va_start(argp, format);",
43 " r = vprintf(format, argp);",
44 " va_end(argp);",
45 " return r;",
46 "}",
47 "",
48 "int hsc_toupper(int c) {",
49 " return toupper(c);",
50 "}",
51 "",
52 "int hsc_tolower(int c) {",
53 " return tolower(c);",
54 "}",
55 "",
56 "int hsc_putchar(int c) {",
57 " return putchar(c);",
58 "}",
59 "",
60 -- "void" should really be "FILE", but we aren't able to
61 -- refer to "FILE" in template-hsc.h as we don't want to
62 -- include <stdio.h> there. We cast to FILE * so as to
63 -- allow compiling with g++.
64 "int hsc_fputs(const char *s, void *stream) {",
65 " return fputs(s, (FILE *)stream);",
66 "}",
67 "",
68 -- "void" should really be "FILE", but we aren't able to
69 -- refer to "FILE" in template-hsc.h as we don't want to
70 -- include <stdio.h> there. We explicitly cast to void *
71 -- to allow compiling with g++.
72 "void *hsc_stdout(void) {",
73 " return (void *)stdout;",
74 "}"
75 ]
76
77 possiblyRemove oUtilsName $ do
78 unless (cNoCompile config) $
79 rawSystemL ("compiling " ++ cUtilsName)
80 beVerbose
81 (cCompiler config)
82 (["-c", cUtilsName, "-o", oUtilsName] ++
83 [cFlag | CompFlag cFlag <- flags])
84
85 f oUtilsName
86