1{-# LANGUAGE CPP #-}
2module DirectCodegen where
3
4{-
5The standard mode for hsc2hs: generates a C file which is
6compiled and run; the output of that program is the .hs file.
7-}
8
9import Data.Char                ( isAlphaNum, toUpper )
10import Data.Foldable            ( foldl' )
11import Control.Monad            ( when, forM_ )
12
13import System.Exit              ( ExitCode(..), exitWith )
14import System.FilePath          ( normalise )
15
16import C
17import Common
18import Flags
19import HSCParser
20import UtilsCodegen
21
22outputDirect :: Config -> FilePath -> FilePath -> FilePath -> String -> [Token] -> IO ()
23outputDirect config outName outDir outBase name toks = do
24
25    let beVerbose    = cVerbose config
26        flags        = cFlags config
27        enableCol    = cColumn config
28        cProgName    = outDir++outBase++"_hsc_make.c"
29        oProgName    = outDir++outBase++"_hsc_make.o"
30        progName     = outDir++outBase++"_hsc_make"
31#if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
32-- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
33-- via GHC has changed a few times, so this seems to be the only way...  :-P * * *
34                          ++ ".exe"
35#endif
36        outHFile     = outBase++"_hsc.h"
37        outHName     = outDir++outHFile
38        outCName     = outDir++outBase++"_hsc.c"
39
40    let execProgName
41            | null outDir = normalise ("./" ++ progName)
42            | otherwise   = progName
43
44    let specials = [(pos, key, arg) | Special pos key arg <- toks]
45
46    let needsC = any (\(_, key, _) -> key == "def") specials
47        needsH = needsC
48        possiblyRemove = if cKeepFiles config
49                         then flip const
50                         else finallyRemove
51
52    let includeGuard = map fixChar outHName
53            where
54            fixChar c | isAlphaNum c = toUpper c
55                      | otherwise    = '_'
56
57    when (cCrossSafe config) $
58        forM_ specials (\ (SourcePos file line _,key,_) ->
59            when (not $ key `elem` ["const","offset","size","alignment","peek","poke","ptr",
60                                    "type","enum","error","warning","include","define","undef",
61                                    "if","ifdef","ifndef", "elif","else","endif"]) $
62             die (file ++ ":" ++ show line ++ " directive \"" ++ key ++ "\" is not safe for cross-compilation"))
63
64    writeBinaryFile cProgName $
65        outTemplateHeaderCProg (cTemplate config)++
66        concatMap outFlagHeaderCProg flags++
67        concatMap outHeaderCProg specials++
68        "\nint main (void)\n{\n"++
69        outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
70        outHsLine (SourcePos name 0 1)++
71        fst (foldl' (outTokenHs enableCol) (id, (True, True)) toks) ""++
72        "    return 0;\n}\n"
73
74    when (cNoCompile config) $ exitWith ExitSuccess
75
76    rawSystemL outDir outBase ("compiling " ++ cProgName) beVerbose
77        (cCompiler config)
78        (  ["-c"]
79        ++ [cProgName]
80        ++ ["-o", oProgName]
81        ++ [f | CompFlag f <- flags]
82        )
83    possiblyRemove cProgName $
84        withUtilsObject config outDir outBase $ \oUtilsName -> do
85
86      rawSystemL outDir outBase ("linking " ++ oProgName) beVerbose
87        (cLinker config)
88        (  [oProgName, oUtilsName]
89        ++ ["-o", progName]
90        ++ [f | LinkFlag f <- flags]
91        )
92      possiblyRemove oProgName $ do
93
94        rawSystemWithStdOutL outDir outBase ("running " ++ execProgName) beVerbose execProgName [] outName
95        possiblyRemove progName $ do
96
97          when needsH $ writeBinaryFile outHName $
98            "#ifndef "++includeGuard++"\n" ++
99            "#define "++includeGuard++"\n" ++
100            "#include <HsFFI.h>\n" ++
101            "#if __NHC__\n" ++
102            "#undef HsChar\n" ++
103            "#define HsChar int\n" ++
104            "#endif\n" ++
105            concatMap outFlagH flags++
106            concatMap outTokenH specials++
107            "#endif\n"
108
109          when needsC $ writeBinaryFile outCName $
110            "#include \""++outHFile++"\"\n"++
111            concatMap outTokenC specials
112            -- NB. outHFile not outHName; works better when processed
113            -- by gcc or mkdependC.
114