1 -----------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.19 2001/02/13 15:53:10 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(..), exitWith, exitFailure)
16 import KludgedSystem (system, defaultCompiler)
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 [] -> return defaultCompiler
218 _ -> onlyOne "linker"
220 writeFile cProgName $
221 concat ["#include \""++t++"\"\n" | Template t <- flags]++
222 concat ["#include "++f++"\n" | Include f <- flags]++
223 outHeaderCProg specials++
224 "\nint main (void)\n{\n"++
225 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
226 outHsLine (newPos name 0 1)++
227 concatMap outTokenHs toks++
230 compilerStatus <- system $
233 concat [" "++f | CompFlag f <- flags]++
236 case compilerStatus of
237 e@(ExitFailure _) -> exitWith e
241 linkerStatus <- system $
243 concat [" "++f | LinkFlag f <- flags]++
247 e@(ExitFailure _) -> exitWith e
251 system (execProgName++" >"++outHsName)
254 when needsH $ writeFile outHName $
255 "#ifndef "++includeGuard++"\n\
256 \#define "++includeGuard++"\n\
257 \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
260 \#include <HsFFI.h>\n\
263 \#define HsChar int\n\
265 concat ["#include "++n++"\n" | Include n <- flags]++
266 concatMap outTokenH specials++
269 when needsC $ writeFile outCName $
270 "#include \""++outHName++"\"\n"++
271 concatMap outTokenC specials
273 onlyOne :: String -> IO a
275 putStrLn ("Only one "++what++" may be specified")
278 outHeaderCProg :: [(SourcePos, String, String)] -> String
280 concatMap $ \(pos, key, arg) -> case key of
281 "include" -> outCLine pos++"#include "++arg++"\n"
282 "define" -> outCLine pos++"#define "++arg++"\n"
283 "undef" -> outCLine pos++"#undef "++arg++"\n"
285 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
286 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
288 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
289 "let" -> case break (== '=') arg of
291 (header, _:body) -> case break isSpace header of
294 "#define hsc_"++name++"("++dropWhile isSpace args++") \
295 \printf ("++joinLines body++");\n"
298 joinLines = concat . intersperse " \\\n" . lines
300 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
301 outHeaderHs flags inH toks =
302 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
303 \ printf (\"{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d #-}\\n\", \
304 \__GLASGOW_HASKELL__);\n\
307 concatMap outSpecial toks
309 outSpecial (pos, key, arg) = case key of
310 "include" -> case inH of
311 Nothing -> outOption ("-#include "++arg)
313 "define" -> case inH of
314 Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
316 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
318 goodForOptD arg = case arg of
320 c:_ | isSpace c -> True
323 toOptD arg = case break isSpace arg of
325 (name, _:value) -> name++'=':dropWhile isSpace value
327 outOption ("-#include "++name++"")
328 | name <- case inH of
329 Nothing -> [name | Include name <- flags]
330 Just name -> ["\""++name++"\""]]
331 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
332 showCString s++"\");\n"
334 outTokenHs :: Token -> String
335 outTokenHs (Text pos text) =
336 case break (== '\n') text of
337 (all, []) -> outText all
339 outText (first++"\n")++
343 outText s = " fputs (\""++showCString s++"\", stdout);\n"
344 outTokenHs (Special pos key arg) =
350 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
352 "enum" -> outCLine pos++outEnum arg
353 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
355 outEnum :: String -> String
357 case break (== ',') arg of
359 (t, _:afterT) -> case break (== ',') afterT of
362 enums (_:s) = case break (== ',') s of
364 this = case break (== '=') $ dropWhile isSpace enum of
366 " hsc_enum ("++t++", "++f++", \
367 \hsc_haskellize (\""++name++"\"), "++
370 " hsc_enum ("++t++", "++f++", \
371 \printf (\"%s\", \""++hsName++"\"), "++
376 outTokenH :: (SourcePos, String, String) -> String
377 outTokenH (pos, key, arg) =
379 "include" -> outCLine pos++"#include "++arg++"\n"
380 "define" -> outCLine pos++"#define " ++arg++"\n"
381 "undef" -> outCLine pos++"#undef " ++arg++"\n"
382 "def" -> outCLine pos++case arg of
383 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
384 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
385 'i':'n':'l':'i':'n':'e':' ':_ ->
390 _ -> "extern "++header++";\n"
391 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
392 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
395 outTokenC :: (SourcePos, String, String) -> String
396 outTokenC (pos, key, arg) =
399 's':'t':'r':'u':'c':'t':' ':_ -> ""
400 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
401 'i':'n':'l':'i':'n':'e':' ':_ ->
407 "\n#ifndef __GNUC__\n\
412 _ -> outCLine pos++arg++"\n"
413 where (header, body) = span (\c -> c /= '{' && c /= '=') arg
414 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
417 conditional :: String -> Bool
418 conditional "if" = True
419 conditional "ifdef" = True
420 conditional "ifndef" = True
421 conditional "elif" = True
422 conditional "else" = True
423 conditional "endif" = True
424 conditional "error" = True
425 conditional "warning" = True
426 conditional _ = False
428 sourceFileName :: SourcePos -> String
429 sourceFileName pos = fileName (sourceName pos)
431 fileName s = case break (== '/') s of
433 (_, _:rest) -> fileName rest
435 outCLine :: SourcePos -> String
437 "# "++show (sourceLine pos)++
438 " \""++showCString (sourceFileName pos)++"\"\n"
440 outHsLine :: SourcePos -> String
443 show (sourceLine pos + 1)++", \""++
444 showCString (sourceFileName pos)++"\");\n"
446 showCString :: String -> String
447 showCString = concatMap showCChar
449 showCChar '\"' = "\\\""
450 showCChar '\'' = "\\\'"
451 showCChar '?' = "\\?"
452 showCChar '\\' = "\\\\"
453 showCChar c | c >= ' ' && c <= '~' = [c]
454 showCChar '\a' = "\\a"
455 showCChar '\b' = "\\b"
456 showCChar '\f' = "\\f"
457 showCChar '\n' = "\\n\"\n \""
458 showCChar '\r' = "\\r"
459 showCChar '\t' = "\\t"
460 showCChar '\v' = "\\v"
462 intToDigit (ord c `quot` 64),
463 intToDigit (ord c `quot` 8 `mod` 8),
464 intToDigit (ord c `mod` 8)]