1 -----------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.6 2001/01/04 19:43:07 qrczak 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)
35 include :: String -> Flag
36 include s@('\"':_) = Include s
37 include s@('<' :_) = Include s
38 include s = Include ("\""++s++"\"")
40 options :: [OptDescr Flag]
42 Option "t" ["template"] (ReqArg Template "FILE") "template file",
43 Option "" ["cc"] (ReqArg Compiler "PROG") "C compiler to use",
44 Option "" ["ld"] (ReqArg Linker "PROG") "linker to use",
45 Option "" ["cflag"] (ReqArg CompFlag "FLAG") "flag to pass to the C compiler",
46 Option "I" [] (ReqArg (CompFlag . ("-I"++))
47 "DIR") "passed to the C compiler",
48 Option "" ["lflag"] (ReqArg LinkFlag "FLAG") "flag to pass to the linker",
49 Option "" ["include"] (ReqArg include "FILE") "as if placed in the source",
50 Option "" ["help"] (NoArg Help) "display this help and exit",
51 Option "" ["version"] (NoArg Version) "output version information and exit"]
56 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]"
58 case getOpt Permute options args of
60 | any isHelp flags -> putStrLn (usageInfo header options)
61 | any isVersion flags -> putStrLn ("hsc2hs-"++version)
63 isHelp Help = True; isHelp _ = False
64 isVersion Version = True; isVersion _ = False
65 (_, [], []) -> putStrLn (prog++": No input files")
66 (flags, files, []) -> mapM_ (processFile flags) files
69 putStrLn (usageInfo header options)
72 processFile :: [Flag] -> String -> IO ()
73 processFile flags name = do
74 parsed <- parseFromFile parser name
76 Left err -> print err >> exitFailure
77 Right toks -> output flags name toks
81 | Special String String
83 parser :: Parser [Token]
84 parser = many (text <|> special)
87 text = liftM Text $ many1 $ satisfy (/= '#') <|> try (string "##" >> return '#')
89 special :: Parser Token
92 skipMany (oneOf " \t")
93 key <- liftM2 (:) (letter <|> char '_') (many (alphaNum <|> char '_'))
95 skipMany (oneOf " \t")
97 return (Special key arg)
99 argument :: Parser String -> Parser String
100 argument eol = liftM concat $ many
101 ( many1 (noneOf "\n\"\'()/[\\]{}")
103 <|> (do char '\"'; a <- cString '\''; char '\"'; return ("\""++a++"\""))
104 <|> (do char '\''; a <- cString '\"'; char '\''; return ("\'"++a++"\'"))
105 <|> (do char '('; a <- nested; char ')'; return ("("++a++")"))
106 <|> (do try (string "/*"); comment; return " ")
107 <|> (do try (string "//"); skipMany (satisfy (/= '\n')); return " ")
109 <|> (do char '['; a <- nested; char ']'; return ("["++a++"]"))
110 <|> (do char '\\'; a <- anyChar; return ['\\',a])
111 <|> (do char '{'; a <- nested; char '}'; return ("{"++a++"}"))
113 where nested = argument (string "\n")
116 comment = (do skipMany1 (noneOf "*"); comment)
117 <|> (do try (string "*/"); return ())
118 <|> (do char '*'; comment)
121 cString :: Char -> Parser String
122 cString otherQuote = liftM concat $ many
123 ( many1 (noneOf "\n\\\'\"")
124 <|> string [otherQuote]
125 <|> (do char '\\'; a <- anyChar; return ['\\',a])
126 <?> "C character or string")
128 output :: [Flag] -> String -> [Token] -> IO ()
129 output flags name toks = let
130 baseName = case reverse name of
131 'c':base -> reverse base
133 cProgName = baseName++"c_make_hs.c"
134 oProgName = baseName++"c_make_hs.o"
135 progName = baseName++"c_make_hs"
137 outHName = baseName++".h"
138 outCName = baseName++".c"
140 execProgName = case progName of
144 specials = [(key, arg) | Special key arg <- toks]
146 needsC = any (\(key, _) -> key == "def") specials
149 includeGuard = map fixChar outHName
151 fixChar c | isAlphaNum c = toUpper c
156 compiler <- case [c | Compiler c <- flags] of
159 _ -> onlyOne "compiler"
160 linker <- case [l | Linker l <- flags] of
163 _ -> onlyOne "linker"
165 writeFile cProgName $
166 concat ["#include \""++t++"\"\n" | Template t <- flags]++
167 concat ["#include "++f++"\n" | Include f <- flags]++
168 outHeaderCProg specials++
169 "\nint main (void)\n{\n"++
170 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
171 concatMap outTokenHs toks++
174 compilerStatus <- system $
177 concat [" "++f | CompFlag f <- flags]++
180 case compilerStatus of
181 e@(ExitFailure _) -> exitWith e
185 linkerStatus <- system $
187 concat [" "++f | LinkFlag f <- flags]++
191 e@(ExitFailure _) -> exitWith e
195 system (execProgName++" >"++outHsName)
198 when needsH $ writeFile outHName $
199 "#ifndef "++includeGuard++"\n\
200 \#define "++includeGuard++"\n\
201 \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
204 \#include <HsFFI.h>\n"++
205 concat ["#include "++n++"\n" | Include n <- flags]++
206 concatMap outTokenH specials++
209 when needsC $ writeFile outCName $
210 "#include \""++outHName++"\"\n"++
211 concatMap outTokenC specials
213 onlyOne :: String -> IO a
215 putStrLn ("Only one "++what++" may be specified")
218 outHeaderCProg :: [(String, String)] -> String
219 outHeaderCProg = concatMap $ \(key, arg) -> case key of
220 "include" -> "#include "++arg++"\n"
221 "define" -> "#define "++arg++"\n"
222 "undef" -> "#undef "++arg++"\n"
224 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
225 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
227 _ | conditional key -> "#"++key++" "++arg++"\n"
228 "let" -> case break (== '=') arg of
230 (header, _:body) -> case break isSpace header of
232 "#define hsc_"++name++"("++dropWhile isSpace args++") \
233 \printf ("++joinLines body++");\n"
236 joinLines = concat . intersperse " \\\n" . lines
238 outHeaderHs :: [Flag] -> Maybe String -> [(String, String)] -> String
239 outHeaderHs flags inH toks =
240 " hsc_begin_options();\n"++
242 concatMap outSpecial toks++
243 " hsc_end_options();\n\n"
245 outSpecial (key, arg) = case key of
246 "include" -> case inH of
247 Nothing -> outOption ("-#include "++arg)
249 "define" -> case inH of
250 Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
252 "option" -> outOption arg
253 _ | conditional key -> "#"++key++" "++arg++"\n"
255 goodForOptD arg = case arg of
257 c:_ | isSpace c -> True
260 toOptD arg = case break isSpace arg of
262 (name, _:value) -> name++'=':dropWhile isSpace value
264 outOption ("-#include "++name++"")
265 | name <- case inH of
266 Nothing -> [name | Include name <- flags]
267 Just name -> ["\""++name++"\""]]
268 outOption s = " hsc_option (\""++showCString s++"\");\n"
270 outTokenHs :: Token -> String
271 outTokenHs (Text s) = " fputs (\""++showCString s++"\", stdout);\n"
272 outTokenHs (Special key arg) = case key of
278 _ | conditional key -> "#"++key++" "++arg++"\n"
280 _ -> " hsc_"++key++" ("++arg++");\n"
282 outTokenH :: (String, String) -> String
283 outTokenH (key, arg) = case key of
284 "include" -> "#include "++arg++"\n"
285 "define" -> "#define " ++arg++"\n"
286 "undef" -> "#undef " ++arg++"\n"
288 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
289 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
290 'i':'n':'l':'i':'n':'e':' ':_ ->
295 _ -> "extern "++header++";\n"
296 where header = takeWhile (\c -> c/='{' && c/='=') arg
297 _ | conditional key -> "#"++key++" "++arg++"\n"
300 outTokenC :: (String, String) -> String
301 outTokenC (key, arg) = case key of
303 's':'t':'r':'u':'c':'t':' ':_ -> ""
304 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
305 'i':'n':'l':'i':'n':'e':' ':_ ->
310 "\n#ifndef __GNUC__\n\
316 where (header, body) = span (\c -> c/='{' && c/='=') arg
317 _ | conditional key -> "#"++key++" "++arg++"\n"
320 conditional :: String -> Bool
321 conditional "if" = True
322 conditional "ifdef" = True
323 conditional "ifndef" = True
324 conditional "elif" = True
325 conditional "else" = True
326 conditional "endif" = True
327 conditional "error" = True
328 conditional _ = False
330 showCString :: String -> String
331 showCString = concatMap showCChar
333 showCChar '\"' = "\\\""
334 showCChar '\'' = "\\\'"
335 showCChar '?' = "\\?"
336 showCChar '\\' = "\\\\"
337 showCChar c | c >= ' ' && c <= '~' = [c]
338 showCChar '\a' = "\\a"
339 showCChar '\b' = "\\b"
340 showCChar '\f' = "\\f"
341 showCChar '\n' = "\\n\"\n \""
342 showCChar '\r' = "\\r"
343 showCChar '\t' = "\\t"
344 showCChar '\v' = "\\v"
346 intToDigit (ord c `quot` 64),
347 intToDigit (ord c `quot` 8 `mod` 8),
348 intToDigit (ord c `mod` 8)]