1 -----------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.5 2001/01/04 13:18:14 simonmar Exp $
4 -- (originally "GlueHsc.hs" by Marcin 'Qrczak' Kowalczyk)
6 -- Program for converting .hsc files to .hs files, by converting the
7 -- file into a C program which is run to generate the Haskell source.
8 -- Certain items known only to the C compiler can then be used in
9 -- the Haskell module; for example #defined constants, byte offsets
10 -- within structures, etc.
12 -- See the documentation in the Users' Guide for more details.
15 import System (getProgName, getArgs, ExitCode(..), system, exitWith, exitFailure)
16 import Directory (removeFile)
18 import Monad (liftM, liftM2, when)
19 import Char (ord, intToDigit, isSpace, isAlphaNum, toUpper)
20 import List (intersperse)
31 include :: String -> Flag
32 include s@('\"':_) = Include s
33 include s@('<' :_) = Include s
34 include s = Include ("\""++s++"\"")
36 options :: [OptDescr Flag]
38 Option "t" ["template"] (ReqArg Template "FILE") "template file",
39 Option "" ["cc"] (ReqArg Compiler "PROG") "C compiler to use",
40 Option "" ["ld"] (ReqArg Linker "PROG") "linker to use",
41 Option "" ["cflag"] (ReqArg CompFlag "FLAG") "flag to pass to the C compiler",
42 Option "I" [] (ReqArg (CompFlag . ("-I"++))
43 "DIR") "passed to the C compiler",
44 Option "" ["lflag"] (ReqArg LinkFlag "FLAG") "flag to pass to the linker",
45 Option "" ["include"] (ReqArg include "FILE") "as if placed in the source",
46 Option "" ["help"] (NoArg Help) "display this help and exit"]
51 let header = "Usage: "++prog++" [OPTIONS...] INPUT.hsc [...]"
53 case getOpt Permute options args of
54 (flags, _, _) | any isHelp flags -> putStrLn (usageInfo header options)
55 where isHelp Help = True; isHelp _ = False
56 (_, [], []) -> putStrLn (prog++": No input files")
57 (flags, files, []) -> mapM_ (processFile flags) files
60 putStrLn (usageInfo header options)
63 processFile :: [Flag] -> String -> IO ()
64 processFile flags name = do
65 parsed <- parseFromFile parser name
67 Left err -> print err >> exitFailure
68 Right toks -> output flags name toks
72 | Special String String
74 parser :: Parser [Token]
75 parser = many (text <|> special)
78 text = liftM Text $ many1 $ satisfy (/= '#') <|> try (string "##" >> return '#')
80 special :: Parser Token
83 skipMany (oneOf " \t")
84 key <- liftM2 (:) (letter <|> char '_') (many (alphaNum <|> char '_'))
86 skipMany (oneOf " \t")
88 return (Special key arg)
90 argument :: Parser String -> Parser String
91 argument eol = liftM concat $ many
92 ( many1 (noneOf "\n\"\'()/[\\]{}")
94 <|> (do char '\"'; a <- cString '\''; char '\"'; return ("\""++a++"\""))
95 <|> (do char '\''; a <- cString '\"'; char '\''; return ("\'"++a++"\'"))
96 <|> (do char '('; a <- nested; char ')'; return ("("++a++")"))
97 <|> (do try (string "/*"); comment; return " ")
98 <|> (do try (string "//"); skipMany (satisfy (/= '\n')); return " ")
100 <|> (do char '['; a <- nested; char ']'; return ("["++a++"]"))
101 <|> (do char '\\'; a <- anyChar; return ['\\',a])
102 <|> (do char '{'; a <- nested; char '}'; return ("{"++a++"}"))
104 where nested = argument (string "\n")
107 comment = (do skipMany1 (noneOf "*"); comment)
108 <|> (do try (string "*/"); return ())
109 <|> (do char '*'; comment)
112 cString :: Char -> Parser String
113 cString otherQuote = liftM concat $ many
114 ( many1 (noneOf "\n\\\'\"")
115 <|> string [otherQuote]
116 <|> (do char '\\'; a <- anyChar; return ['\\',a])
117 <?> "C character or string")
119 output :: [Flag] -> String -> [Token] -> IO ()
120 output flags name toks = let
121 baseName = case reverse name of
122 'c':base -> reverse base
124 cProgName = baseName++"c_make_hs.c"
125 oProgName = baseName++"c_make_hs.o"
126 progName = baseName++"c_make_hs"
128 outHName = baseName++".h"
129 outCName = baseName++".c"
131 execProgName = case progName of
135 specials = [(key, arg) | Special key arg <- toks]
137 needsC = any (\(key, _) -> key == "def") specials
140 includeGuard = map fixChar outHName
142 fixChar c | isAlphaNum c = toUpper c
147 compiler <- case [c | Compiler c <- flags] of
150 _ -> onlyOne "compiler"
151 linker <- case [l | Linker l <- flags] of
154 _ -> onlyOne "linker"
156 writeFile cProgName $
157 concat ["#include \""++t++"\"\n" | Template t <- flags]++
158 concat ["#include "++f++"\n" | Include f <- flags]++
159 outHeaderCProg specials++
160 "\nint main (void)\n{\n"++
161 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
162 concatMap outTokenHs toks++
165 compilerStatus <- system $
168 concat [" "++f | CompFlag f <- flags]++
171 case compilerStatus of
172 e@(ExitFailure _) -> exitWith e
176 linkerStatus <- system $
178 concat [" "++f | LinkFlag f <- flags]++
182 e@(ExitFailure _) -> exitWith e
186 system (execProgName++" >"++outHsName)
189 when needsH $ writeFile outHName $
190 "#ifndef "++includeGuard++"\n\
191 \#define "++includeGuard++"\n\
192 \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
195 \#include <HsFFI.h>\n"++
196 concat ["#include "++name++"\n" | Include name <- flags]++
197 concatMap outTokenH specials++
200 when needsC $ writeFile outCName $
201 "#include \""++outHName++"\"\n"++
202 concatMap outTokenC specials
204 onlyOne :: String -> IO a
206 putStrLn ("Only one "++what++" may be specified")
209 outHeaderCProg :: [(String, String)] -> String
210 outHeaderCProg = concatMap $ \(key, arg) -> case key of
211 "include" -> "#include "++arg++"\n"
212 "define" -> "#define "++arg++"\n"
213 "undef" -> "#undef "++arg++"\n"
215 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
216 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
218 _ | conditional key -> "#"++key++" "++arg++"\n"
219 "let" -> case break (== '=') arg of
221 (header, _:body) -> case break isSpace header of
223 "#define hsc_"++name++"("++dropWhile isSpace args++") \
224 \printf ("++joinLines body++");\n"
227 joinLines = concat . intersperse " \\\n" . lines
229 outHeaderHs :: [Flag] -> Maybe String -> [(String, String)] -> String
230 outHeaderHs flags inH toks =
231 " hsc_begin_options();\n"++
233 concatMap outSpecial toks++
234 " hsc_end_options();\n\n"
236 outSpecial (key, arg) = case key of
237 "include" -> case inH of
238 Nothing -> outOption ("-#include "++arg)
240 "define" -> case inH of
241 Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
243 "option" -> outOption arg
244 _ | conditional key -> "#"++key++" "++arg++"\n"
246 goodForOptD arg = case arg of
248 c:_ | isSpace c -> True
251 toOptD arg = case break isSpace arg of
253 (name, _:value) -> name++'=':dropWhile isSpace value
255 outOption ("-#include "++name++"")
256 | name <- case inH of
257 Nothing -> [name | Include name <- flags]
258 Just name -> ["\""++name++"\""]]
259 outOption s = " hsc_option (\""++showCString s++"\");\n"
261 outTokenHs :: Token -> String
262 outTokenHs (Text s) = " fputs (\""++showCString s++"\", stdout);\n"
263 outTokenHs (Special key arg) = case key of
269 _ | conditional key -> "#"++key++" "++arg++"\n"
271 _ -> " hsc_"++key++" ("++arg++");\n"
273 outTokenH :: (String, String) -> String
274 outTokenH (key, arg) = case key of
275 "include" -> "#include "++arg++"\n"
276 "define" -> "#define " ++arg++"\n"
277 "undef" -> "#undef " ++arg++"\n"
279 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
280 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
281 'i':'n':'l':'i':'n':'e':' ':_ ->
286 _ -> "extern "++header++";\n"
287 where header = takeWhile (\c -> c/='{' && c/='=') arg
288 _ | conditional key -> "#"++key++" "++arg++"\n"
291 outTokenC :: (String, String) -> String
292 outTokenC (key, arg) = case key of
294 's':'t':'r':'u':'c':'t':' ':_ -> ""
295 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
296 'i':'n':'l':'i':'n':'e':' ':_ ->
301 "\n#ifndef __GNUC__\n\
307 where (header, body) = span (\c -> c/='{' && c/='=') arg
308 _ | conditional key -> "#"++key++" "++arg++"\n"
311 conditional :: String -> Bool
312 conditional "if" = True
313 conditional "ifdef" = True
314 conditional "ifndef" = True
315 conditional "elif" = True
316 conditional "else" = True
317 conditional "endif" = True
318 conditional "error" = True
319 conditional _ = False
321 showCString :: String -> String
322 showCString = concatMap showCChar
324 showCChar '\"' = "\\\""
325 showCChar '\'' = "\\\'"
326 showCChar '?' = "\\?"
327 showCChar '\\' = "\\\\"
328 showCChar c | c >= ' ' && c <= '~' = [c]
329 showCChar '\a' = "\\a"
330 showCChar '\b' = "\\b"
331 showCChar '\f' = "\\f"
332 showCChar '\n' = "\\n\"\n \""
333 showCChar '\r' = "\\r"
334 showCChar '\t' = "\\t"
335 showCChar '\v' = "\\v"
337 intToDigit (ord c `quot` 64),
338 intToDigit (ord c `quot` 8 `mod` 8),
339 intToDigit (ord c `mod` 8)]