1module UtilsCodegen where
2
3{-
4Generate the utility code for hsc2hs.
5
6We don't want to include C headers in template-hsc.h
7See GHC trac #2897
8-}
9
10import Control.Monad
11
12import C
13import Common
14import Flags
15
16withUtilsObject :: Config -> FilePath -> FilePath
17                -> (FilePath -> IO a)
18                -> IO a
19withUtilsObject 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             -- These header will cause a mismatch with any mingw-w64 header by
32             -- including system headers before user headers in the hsc file.
33             -- We *MUST* include user headers *BEFORE* automatic ones.  */
34            [outTemplateHeaderCProg (cTemplate config),
35             "",
36             "#include <stddef.h>",
37             "#include <string.h>",
38             "#include <stdio.h>",
39             "#include <stdarg.h>",
40             "#include <ctype.h>",
41             "",
42             "int hsc_printf(const char *format, ...) {",
43             "    int r;",
44             "    va_list argp;",
45             "    va_start(argp, format);",
46             "    r = vprintf(format, argp);",
47             "    va_end(argp);",
48             "    return r;",
49             "}",
50             "",
51             "int hsc_toupper(int c) {",
52             "    return toupper(c);",
53             "}",
54             "",
55             "int hsc_tolower(int c) {",
56             "    return tolower(c);",
57             "}",
58             "",
59             "int hsc_putchar(int c) {",
60             "    return putchar(c);",
61             "}",
62             "",
63             -- "void" should really be "FILE", but we aren't able to
64             -- refer to "FILE" in template-hsc.h as we don't want to
65             -- include <stdio.h> there. We cast to FILE * so as to
66             -- allow compiling with g++.
67             "int hsc_fputs(const char *s, void *stream) {",
68             "    return fputs(s, (FILE *)stream);",
69             "}",
70             "",
71             -- "void" should really be "FILE", but we aren't able to
72             -- refer to "FILE" in template-hsc.h as we don't want to
73             -- include <stdio.h> there. We explicitly cast to void *
74             -- to allow compiling with g++.
75             "void *hsc_stdout(void) {",
76             "    return (void *)stdout;",
77             "}"
78            ]
79
80        possiblyRemove oUtilsName $ do
81           unless (cNoCompile config) $
82               rawSystemL outDir (outBase ++ "_utils") ("compiling " ++ cUtilsName)
83                          beVerbose
84                          (cCompiler config)
85                          (["-c", cUtilsName, "-o", oUtilsName] ++
86                           [cFlag | CompFlag cFlag <- flags])
87
88           f oUtilsName
89