1 -----------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.14 2001/01/24 22:37:15 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)
19 import Monad (liftM, liftM2, when)
20 import Char (ord, intToDigit, isSpace, isAlpha, isAlphaNum, toUpper)
21 import List (intersperse)
24 version = "hsc2hs-0.64"
36 include :: String -> Flag
37 include s@('\"':_) = Include s
38 include s@('<' :_) = Include s
39 include s = Include ("\""++s++"\"")
41 options :: [OptDescr Flag]
43 Option "t" ["template"] (ReqArg Template "FILE") "template file",
44 Option "" ["cc"] (ReqArg Compiler "PROG") "C compiler to use",
45 Option "" ["ld"] (ReqArg Linker "PROG") "linker to use",
46 Option "" ["cflag"] (ReqArg CompFlag "FLAG") "flag to pass to the C compiler",
47 Option "I" [] (ReqArg (CompFlag . ("-I"++))
48 "DIR") "passed to the C compiler",
49 Option "" ["lflag"] (ReqArg LinkFlag "FLAG") "flag to pass to the linker",
50 Option "" ["include"] (ReqArg include "FILE") "as if placed in the source",
51 Option "" ["help"] (NoArg Help) "display this help and exit",
52 Option "" ["version"] (NoArg Version) "output version information and exit"]
57 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]"
59 case getOpt Permute options args of
61 | any isHelp flags -> putStrLn (usageInfo header options)
62 | any isVersion flags -> putStrLn version
64 isHelp Help = True; isHelp _ = False
65 isVersion Version = True; isVersion _ = False
66 (_, [], []) -> putStrLn (prog++": No input files")
67 (flags, files, []) -> mapM_ (processFile flags) files
70 putStrLn (usageInfo header options)
73 processFile :: [Flag] -> String -> IO ()
74 processFile flags name = do
75 parsed <- parseFromFile parser name
77 Left err -> do print err; exitFailure
78 Right toks -> output flags name toks
81 = Text SourcePos String
82 | Special SourcePos String String
84 parser :: Parser [Token]
85 parser = many (text <|> special)
90 liftM (Text pos . concat) $ many1
91 ( many1 (satisfy (\ch -> not (isAlpha ch || ch `elem` "\"#'-_{")))
92 <|> (do a <- satisfy (\ch -> isAlpha ch || ch == '_')
93 b <- many (satisfy (\ch -> isAlphaNum ch || ch == '_' || ch == '\''))
95 <|> (do char '\"'; a <- hsString '\"'; char '\"'; return ("\""++a++"\""))
96 <|> (do try (string "##"); return "#")
97 <|> (do char '\''; a <- hsString '\''; char '\''; return ("\'"++a++"\'"))
98 <|> (do try (string "--"); a <- many (satisfy (/= '\n')); return ("--"++a))
100 <|> (do try (string "{-#"); optional (try linePragma); a <- hsComment; return ("{-#"++a))
101 <|> (do try (string "{-"); a <- hsComment; return ("{-"++a))
103 <?> "Haskell source")
105 linePragma :: Parser ()
114 file <- many (satisfy (/= '\"'))
119 setPosition (newPos file (read line - 1) 1)
121 hsComment :: Parser String
123 ( (do a <- many1 (noneOf "-{"); b <- hsComment; return (a++b))
124 <|> try (string "-}")
125 <|> (do char '-'; b <- hsComment; return ('-':b))
126 <|> (do try (string "{-"); a <- hsComment; b <- hsComment; return ("{-"++a++b))
127 <|> (do char '{'; b <- hsComment; return ('{':b))
128 <?> "Haskell comment")
130 hsString :: Char -> Parser String
133 ( many1 (noneOf (quote:"\n\\"))
134 <|> (do char '\\'; a <- escape; return ('\\':a))
135 <?> "Haskell character or string")
137 escape = (do a <- many1 (satisfy isSpace); char '\\'; return (a++"\\"))
138 <|> (do a <- anyChar; return [a])
140 special :: Parser Token
144 skipMany (oneOf " \t")
145 key <- liftM2 (:) (letter <|> char '_') (many (alphaNum <|> char '_'))
147 skipMany (oneOf " \t")
148 arg <- argument pzero
149 return (Special pos key arg)
151 argument :: Parser String -> Parser String
154 ( many1 (noneOf "\n\"\'()/[\\]{}")
156 <|> (do char '\"'; a <- cString '\"'; char '\"'; return ("\""++a++"\""))
157 <|> (do char '\''; a <- cString '\''; char '\''; return ("\'"++a++"\'"))
158 <|> (do char '('; a <- nested; char ')'; return ("("++a++")"))
159 <|> (do try (string "/*"); cComment; return " ")
160 <|> (do try (string "//"); skipMany (satisfy (/= '\n')); return " ")
162 <|> (do char '['; a <- nested; char ']'; return ("["++a++"]"))
163 <|> (do char '\\'; a <- anyChar; return $ if a == '\n' then [] else ['\\',a])
164 <|> (do char '{'; a <- nested; char '}'; return ("{"++a++"}"))
166 where nested = argument (string "\n")
168 cComment :: Parser ()
170 ( (do skipMany1 (noneOf "*"); cComment)
171 <|> (do try (string "*/"); return ())
172 <|> (do char '*'; cComment)
175 cString :: Char -> Parser String
178 ( many1 (noneOf (quote:"\n\\"))
179 <|> (do char '\\'; a <- anyChar; return ['\\',a])
180 <?> "C character or string")
182 output :: [Flag] -> String -> [Token] -> IO ()
183 output flags name toks = let
184 baseName = case reverse name of
185 'c':base -> reverse base
187 cProgName = baseName++"c_make_hs.c"
188 oProgName = baseName++"c_make_hs.o"
189 progName = baseName++"c_make_hs"
191 outHName = baseName++".h"
192 outCName = baseName++".c"
194 execProgName = case progName of
198 specials = [(pos, key, arg) | Special pos key arg <- toks]
200 needsC = any (\(_, key, _) -> key == "def") specials
203 includeGuard = map fixChar outHName
205 fixChar c | isAlphaNum c = toUpper c
210 compiler <- case [c | Compiler c <- flags] of
213 _ -> onlyOne "compiler"
214 linker <- case [l | Linker l <- flags] of
217 _ -> onlyOne "linker"
219 writeFile cProgName $
220 concat ["#include \""++t++"\"\n" | Template t <- flags]++
221 concat ["#include "++f++"\n" | Include f <- flags]++
222 outHeaderCProg specials++
223 "\nint main (void)\n{\n"++
224 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
225 outHsLine (newPos name 0 1)++
226 concatMap outTokenHs toks++
229 compilerStatus <- system $
232 concat [" "++f | CompFlag f <- flags]++
235 case compilerStatus of
236 e@(ExitFailure _) -> exitWith e
240 linkerStatus <- system $
242 concat [" "++f | LinkFlag f <- flags]++
246 e@(ExitFailure _) -> exitWith e
250 system (execProgName++" >"++outHsName)
253 when needsH $ writeFile outHName $
254 "#ifndef "++includeGuard++"\n\
255 \#define "++includeGuard++"\n\
256 \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
259 \#include <HsFFI.h>\n"++
260 concat ["#include "++n++"\n" | Include n <- flags]++
261 concatMap outTokenH specials++
264 when needsC $ writeFile outCName $
265 "#include \""++outHName++"\"\n"++
266 concatMap outTokenC specials
268 onlyOne :: String -> IO a
270 putStrLn ("Only one "++what++" may be specified")
273 outHeaderCProg :: [(SourcePos, String, String)] -> String
275 concatMap $ \(pos, key, arg) -> case key of
276 "include" -> outCLine pos++"#include "++arg++"\n"
277 "define" -> outCLine pos++"#define "++arg++"\n"
278 "undef" -> outCLine pos++"#undef "++arg++"\n"
280 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
281 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
283 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
284 "let" -> case break (== '=') arg of
286 (header, _:body) -> case break isSpace header of
289 "#define hsc_"++name++"("++dropWhile isSpace args++") \
290 \printf ("++joinLines body++");\n"
293 joinLines = concat . intersperse " \\\n" . lines
295 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
296 outHeaderHs flags inH toks =
297 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
298 \ printf (\"{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d #-}\\n\", \
299 \__GLASGOW_HASKELL__);\n\
302 concatMap outSpecial toks
304 outSpecial (pos, key, arg) = case key of
305 "include" -> case inH of
306 Nothing -> outOption ("-#include "++arg)
308 "define" -> case inH of
309 Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
311 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
313 goodForOptD arg = case arg of
315 c:_ | isSpace c -> True
318 toOptD arg = case break isSpace arg of
320 (name, _:value) -> name++'=':dropWhile isSpace value
322 outOption ("-#include "++name++"")
323 | name <- case inH of
324 Nothing -> [name | Include name <- flags]
325 Just name -> ["\""++name++"\""]]
326 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
327 showCString s++"\");\n"
329 outTokenHs :: Token -> String
330 outTokenHs (Text pos text) =
331 case break (== '\n') text of
332 (all, []) -> outText all
334 outText (first++"\n")++
338 outText s = " fputs (\""++showCString s++"\", stdout);\n"
339 outTokenHs (Special pos key arg) =
345 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
347 "enum" -> outCLine pos++outEnum arg
348 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
350 outEnum :: String -> String
352 case break (== ',') arg of
354 (t, _:afterT) -> case break (== ',') afterT of
357 enums (_:s) = case break (== ',') s of
359 this = case break (== '=') $ dropWhile isSpace enum of
361 " hsc_enum ("++t++", "++f++", \
362 \hsc_haskellize (\""++name++"\"), "++
365 " hsc_enum ("++t++", "++f++", \
366 \printf (\"%s\", \""++hsName++"\"), "++
371 outTokenH :: (SourcePos, String, String) -> String
372 outTokenH (pos, key, arg) =
374 "include" -> outCLine pos++"#include "++arg++"\n"
375 "define" -> outCLine pos++"#define " ++arg++"\n"
376 "undef" -> outCLine pos++"#undef " ++arg++"\n"
377 "def" -> outCLine pos++case arg of
378 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
379 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
380 'i':'n':'l':'i':'n':'e':' ':_ ->
385 _ -> "extern "++header++";\n"
386 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
387 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
390 outTokenC :: (SourcePos, String, String) -> String
391 outTokenC (pos, key, arg) =
394 's':'t':'r':'u':'c':'t':' ':_ -> ""
395 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
396 'i':'n':'l':'i':'n':'e':' ':_ ->
402 "\n#ifndef __GNUC__\n\
407 _ -> outCLine pos++arg++"\n"
408 where (header, body) = span (\c -> c /= '{' && c /= '=') arg
409 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
412 conditional :: String -> Bool
413 conditional "if" = True
414 conditional "ifdef" = True
415 conditional "ifndef" = True
416 conditional "elif" = True
417 conditional "else" = True
418 conditional "endif" = True
419 conditional "error" = True
420 conditional "warning" = True
421 conditional _ = False
423 sourceFileName :: SourcePos -> String
424 sourceFileName pos = fileName (sourceName pos)
426 fileName s = case break (== '/') s of
428 (_, _:rest) -> fileName rest
430 outCLine :: SourcePos -> String
432 "# "++show (sourceLine pos)++
433 " \""++showCString (sourceFileName pos)++"\"\n"
435 outHsLine :: SourcePos -> String
438 show (sourceLine pos + 1)++", \""++
439 showCString (sourceFileName pos)++"\");\n"
441 showCString :: String -> String
442 showCString = concatMap showCChar
444 showCChar '\"' = "\\\""
445 showCChar '\'' = "\\\'"
446 showCChar '?' = "\\?"
447 showCChar '\\' = "\\\\"
448 showCChar c | c >= ' ' && c <= '~' = [c]
449 showCChar '\a' = "\\a"
450 showCChar '\b' = "\\b"
451 showCChar '\f' = "\\f"
452 showCChar '\n' = "\\n\"\n \""
453 showCChar '\r' = "\\r"
454 showCChar '\t' = "\\t"
455 showCChar '\v' = "\\v"
457 intToDigit (ord c `quot` 64),
458 intToDigit (ord c `quot` 8 `mod` 8),
459 intToDigit (ord c `mod` 8)]