1 -----------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.18 2001/02/13 15:09:02 rrt 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(..), exitWith, exitFailure)
16 import KludgedSystem (system)
17 import Directory (removeFile)
20 import Monad (liftM, liftM2, when)
21 import Char (ord, intToDigit, isSpace, isAlpha, isAlphaNum, toUpper)
22 import List (intersperse)
25 version = "hsc2hs-0.64"
37 include :: String -> Flag
38 include s@('\"':_) = Include s
39 include s@('<' :_) = Include s
40 include s = Include ("\""++s++"\"")
42 options :: [OptDescr Flag]
44 Option "t" ["template"] (ReqArg Template "FILE") "template file",
45 Option "" ["cc"] (ReqArg Compiler "PROG") "C compiler to use",
46 Option "" ["ld"] (ReqArg Linker "PROG") "linker to use",
47 Option "" ["cflag"] (ReqArg CompFlag "FLAG") "flag to pass to the C compiler",
48 Option "I" [] (ReqArg (CompFlag . ("-I"++))
49 "DIR") "passed to the C compiler",
50 Option "" ["lflag"] (ReqArg LinkFlag "FLAG") "flag to pass to the linker",
51 Option "" ["include"] (ReqArg include "FILE") "as if placed in the source",
52 Option "" ["help"] (NoArg Help) "display this help and exit",
53 Option "" ["version"] (NoArg Version) "output version information and exit"]
58 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]"
60 case getOpt Permute options args of
62 | any isHelp flags -> putStrLn (usageInfo header options)
63 | any isVersion flags -> putStrLn version
65 isHelp Help = True; isHelp _ = False
66 isVersion Version = True; isVersion _ = False
67 (_, [], []) -> putStrLn (prog++": No input files")
68 (flags, files, []) -> mapM_ (processFile flags) files
71 putStrLn (usageInfo header options)
74 processFile :: [Flag] -> String -> IO ()
75 processFile flags name = do
76 parsed <- parseFromFile parser name
78 Left err -> do print err; exitFailure
79 Right toks -> output flags name toks
82 = Text SourcePos String
83 | Special SourcePos String String
85 parser :: Parser [Token]
86 parser = many (text <|> special)
91 liftM (Text pos . concat) $ many1
92 ( many1 (satisfy (\ch -> not (isAlpha ch || ch `elem` "\"#'-_{")))
93 <|> (do a <- satisfy (\ch -> isAlpha ch || ch == '_')
94 b <- many (satisfy (\ch -> isAlphaNum ch || ch == '_' || ch == '\''))
96 <|> (do char '\"'; a <- hsString '\"'; char '\"'; return ("\""++a++"\""))
97 <|> (do try (string "##"); return "#")
98 <|> (do char '\''; a <- hsString '\''; char '\''; return ("\'"++a++"\'"))
99 <|> (do try (string "--"); a <- many (satisfy (/= '\n')); return ("--"++a))
101 <|> (do try (string "{-#"); optional (try linePragma); a <- hsComment; return ("{-#"++a))
102 <|> (do try (string "{-"); a <- hsComment; return ("{-"++a))
104 <?> "Haskell source")
106 linePragma :: Parser ()
115 file <- many (satisfy (/= '\"'))
120 setPosition (newPos file (read line - 1) 1)
122 hsComment :: Parser String
124 ( (do a <- many1 (noneOf "-{"); b <- hsComment; return (a++b))
125 <|> try (string "-}")
126 <|> (do char '-'; b <- hsComment; return ('-':b))
127 <|> (do try (string "{-"); a <- hsComment; b <- hsComment; return ("{-"++a++b))
128 <|> (do char '{'; b <- hsComment; return ('{':b))
129 <?> "Haskell comment")
131 hsString :: Char -> Parser String
134 ( many1 (noneOf (quote:"\n\\"))
135 <|> (do char '\\'; a <- escape; return ('\\':a))
136 <?> "Haskell character or string")
138 escape = (do a <- many1 (satisfy isSpace); char '\\'; return (a++"\\"))
139 <|> (do a <- anyChar; return [a])
141 special :: Parser Token
145 skipMany (oneOf " \t")
146 key <- liftM2 (:) (letter <|> char '_') (many (alphaNum <|> char '_'))
148 skipMany (oneOf " \t")
149 arg <- argument pzero
150 return (Special pos key arg)
152 argument :: Parser String -> Parser String
155 ( many1 (noneOf "\n\"\'()/[\\]{}")
157 <|> (do char '\"'; a <- cString '\"'; char '\"'; return ("\""++a++"\""))
158 <|> (do char '\''; a <- cString '\''; char '\''; return ("\'"++a++"\'"))
159 <|> (do char '('; a <- nested; char ')'; return ("("++a++")"))
160 <|> (do try (string "/*"); cComment; return " ")
161 <|> (do try (string "//"); skipMany (satisfy (/= '\n')); return " ")
163 <|> (do char '['; a <- nested; char ']'; return ("["++a++"]"))
164 <|> (do char '\\'; a <- anyChar; return $ if a == '\n' then [] else ['\\',a])
165 <|> (do char '{'; a <- nested; char '}'; return ("{"++a++"}"))
167 where nested = argument (string "\n")
169 cComment :: Parser ()
171 ( (do skipMany1 (noneOf "*"); cComment)
172 <|> (do try (string "*/"); return ())
173 <|> (do char '*'; cComment)
176 cString :: Char -> Parser String
179 ( many1 (noneOf (quote:"\n\\"))
180 <|> (do char '\\'; a <- anyChar; return ['\\',a])
181 <?> "C character or string")
183 output :: [Flag] -> String -> [Token] -> IO ()
184 output flags name toks = let
185 baseName = case reverse name of
186 'c':base -> reverse base
188 cProgName = baseName++"c_make_hs.c"
189 oProgName = baseName++"c_make_hs.o"
190 progName = baseName++"c_make_hs"
192 outHName = baseName++".h"
193 outCName = baseName++".c"
195 execProgName = case progName of
199 specials = [(pos, key, arg) | Special pos key arg <- toks]
201 needsC = any (\(_, key, _) -> key == "def") specials
204 includeGuard = map fixChar outHName
206 fixChar c | isAlphaNum c = toUpper c
211 compiler <- case [c | Compiler c <- flags] of
214 _ -> onlyOne "compiler"
215 linker <- case [l | Linker l <- flags] of
216 #ifndef mingw32_TARGET_OS
219 [] -> return "gcc -mno-cygwin"
222 _ -> onlyOne "linker"
224 writeFile cProgName $
225 concat ["#include \""++t++"\"\n" | Template t <- flags]++
226 concat ["#include "++f++"\n" | Include f <- flags]++
227 outHeaderCProg specials++
228 "\nint main (void)\n{\n"++
229 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
230 outHsLine (newPos name 0 1)++
231 concatMap outTokenHs toks++
234 compilerStatus <- system $
237 concat [" "++f | CompFlag f <- flags]++
240 case compilerStatus of
241 e@(ExitFailure _) -> exitWith e
245 linkerStatus <- system $
247 concat [" "++f | LinkFlag f <- flags]++
251 e@(ExitFailure _) -> exitWith e
255 system (execProgName++" >"++outHsName)
258 when needsH $ writeFile outHName $
259 "#ifndef "++includeGuard++"\n\
260 \#define "++includeGuard++"\n\
261 \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
264 \#include <HsFFI.h>\n\
267 \#define HsChar int\n\
269 concat ["#include "++n++"\n" | Include n <- flags]++
270 concatMap outTokenH specials++
273 when needsC $ writeFile outCName $
274 "#include \""++outHName++"\"\n"++
275 concatMap outTokenC specials
277 onlyOne :: String -> IO a
279 putStrLn ("Only one "++what++" may be specified")
282 outHeaderCProg :: [(SourcePos, String, String)] -> String
284 concatMap $ \(pos, key, arg) -> case key of
285 "include" -> outCLine pos++"#include "++arg++"\n"
286 "define" -> outCLine pos++"#define "++arg++"\n"
287 "undef" -> outCLine pos++"#undef "++arg++"\n"
289 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
290 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
292 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
293 "let" -> case break (== '=') arg of
295 (header, _:body) -> case break isSpace header of
298 "#define hsc_"++name++"("++dropWhile isSpace args++") \
299 \printf ("++joinLines body++");\n"
302 joinLines = concat . intersperse " \\\n" . lines
304 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
305 outHeaderHs flags inH toks =
306 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
307 \ printf (\"{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d #-}\\n\", \
308 \__GLASGOW_HASKELL__);\n\
311 concatMap outSpecial toks
313 outSpecial (pos, key, arg) = case key of
314 "include" -> case inH of
315 Nothing -> outOption ("-#include "++arg)
317 "define" -> case inH of
318 Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
320 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
322 goodForOptD arg = case arg of
324 c:_ | isSpace c -> True
327 toOptD arg = case break isSpace arg of
329 (name, _:value) -> name++'=':dropWhile isSpace value
331 outOption ("-#include "++name++"")
332 | name <- case inH of
333 Nothing -> [name | Include name <- flags]
334 Just name -> ["\""++name++"\""]]
335 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
336 showCString s++"\");\n"
338 outTokenHs :: Token -> String
339 outTokenHs (Text pos text) =
340 case break (== '\n') text of
341 (all, []) -> outText all
343 outText (first++"\n")++
347 outText s = " fputs (\""++showCString s++"\", stdout);\n"
348 outTokenHs (Special pos key arg) =
354 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
356 "enum" -> outCLine pos++outEnum arg
357 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
359 outEnum :: String -> String
361 case break (== ',') arg of
363 (t, _:afterT) -> case break (== ',') afterT of
366 enums (_:s) = case break (== ',') s of
368 this = case break (== '=') $ dropWhile isSpace enum of
370 " hsc_enum ("++t++", "++f++", \
371 \hsc_haskellize (\""++name++"\"), "++
374 " hsc_enum ("++t++", "++f++", \
375 \printf (\"%s\", \""++hsName++"\"), "++
380 outTokenH :: (SourcePos, String, String) -> String
381 outTokenH (pos, key, arg) =
383 "include" -> outCLine pos++"#include "++arg++"\n"
384 "define" -> outCLine pos++"#define " ++arg++"\n"
385 "undef" -> outCLine pos++"#undef " ++arg++"\n"
386 "def" -> outCLine pos++case arg of
387 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
388 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
389 'i':'n':'l':'i':'n':'e':' ':_ ->
394 _ -> "extern "++header++";\n"
395 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
396 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
399 outTokenC :: (SourcePos, String, String) -> String
400 outTokenC (pos, key, arg) =
403 's':'t':'r':'u':'c':'t':' ':_ -> ""
404 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
405 'i':'n':'l':'i':'n':'e':' ':_ ->
411 "\n#ifndef __GNUC__\n\
416 _ -> outCLine pos++arg++"\n"
417 where (header, body) = span (\c -> c /= '{' && c /= '=') arg
418 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
421 conditional :: String -> Bool
422 conditional "if" = True
423 conditional "ifdef" = True
424 conditional "ifndef" = True
425 conditional "elif" = True
426 conditional "else" = True
427 conditional "endif" = True
428 conditional "error" = True
429 conditional "warning" = True
430 conditional _ = False
432 sourceFileName :: SourcePos -> String
433 sourceFileName pos = fileName (sourceName pos)
435 fileName s = case break (== '/') s of
437 (_, _:rest) -> fileName rest
439 outCLine :: SourcePos -> String
441 "# "++show (sourceLine pos)++
442 " \""++showCString (sourceFileName pos)++"\"\n"
444 outHsLine :: SourcePos -> String
447 show (sourceLine pos + 1)++", \""++
448 showCString (sourceFileName pos)++"\");\n"
450 showCString :: String -> String
451 showCString = concatMap showCChar
453 showCChar '\"' = "\\\""
454 showCChar '\'' = "\\\'"
455 showCChar '?' = "\\?"
456 showCChar '\\' = "\\\\"
457 showCChar c | c >= ' ' && c <= '~' = [c]
458 showCChar '\a' = "\\a"
459 showCChar '\b' = "\\b"
460 showCChar '\f' = "\\f"
461 showCChar '\n' = "\\n\"\n \""
462 showCChar '\r' = "\\r"
463 showCChar '\t' = "\\t"
464 showCChar '\v' = "\\v"
466 intToDigit (ord c `quot` 64),
467 intToDigit (ord c `quot` 8 `mod` 8),
468 intToDigit (ord c `mod` 8)]