1 -----------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.10 2001/01/13 19:46:49 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) -> outCLine pos ++ case key of
276 "include" -> "#include "++arg++"\n"
277 "define" -> "#define "++arg++"\n"
278 "undef" -> "#undef "++arg++"\n"
280 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
281 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
283 _ | conditional key -> "#"++key++" "++arg++"\n"
284 "let" -> case break (== '=') arg of
286 (header, _:body) -> case break isSpace header of
288 "#define hsc_"++name++"("++dropWhile isSpace args++") \
289 \printf ("++joinLines body++");\n"
292 joinLines = concat . intersperse " \\\n" . lines
294 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
295 outHeaderHs flags inH toks =
296 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
297 \ printf (\"{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d #-}\\n\", \
298 \__GLASGOW_HASKELL__);\n\
301 concatMap outSpecial toks
303 outSpecial (pos, key, arg) = outCLine pos ++ case key of
304 "include" -> case inH of
305 Nothing -> outOption ("-#include "++arg)
307 "define" -> case inH of
308 Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
310 _ | conditional key -> "#"++key++" "++arg++"\n"
312 goodForOptD arg = case arg of
314 c:_ | isSpace c -> True
317 toOptD arg = case break isSpace arg of
319 (name, _:value) -> name++'=':dropWhile isSpace value
321 outOption ("-#include "++name++"")
322 | name <- case inH of
323 Nothing -> [name | Include name <- flags]
324 Just name -> ["\""++name++"\""]]
325 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
326 showCString s++"\");\n"
328 outTokenHs :: Token -> String
329 outTokenHs (Text pos text) =
330 case break (== '\n') text of
331 (all, []) -> outText all
333 outText (first++"\n")++
337 outText s = " fputs (\""++showCString s++"\", stdout);\n"
338 outTokenHs (Special pos key arg) =
339 outCLine pos ++ case key of
344 _ | conditional key -> "#"++key++" "++arg++"\n"
346 _ -> " hsc_"++key++" ("++arg++");\n"
348 outTokenH :: (SourcePos, String, String) -> String
349 outTokenH (pos, key, arg) =
350 outCLine pos ++ case key of
351 "include" -> "#include "++arg++"\n"
352 "define" -> "#define " ++arg++"\n"
353 "undef" -> "#undef " ++arg++"\n"
355 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
356 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
357 'i':'n':'l':'i':'n':'e':' ':_ ->
362 _ -> "extern "++header++";\n"
363 where header = takeWhile (\c -> c/='{' && c/='=') arg
364 _ | conditional key -> "#"++key++" "++arg++"\n"
367 outTokenC :: (SourcePos, String, String) -> String
368 outTokenC (pos, key, arg) =
369 outCLine pos ++ case key of
371 's':'t':'r':'u':'c':'t':' ':_ -> ""
372 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
373 'i':'n':'l':'i':'n':'e':' ':_ ->
378 "\n#ifndef __GNUC__\n\
384 where (header, body) = span (\c -> c/='{' && c/='=') arg
385 _ | conditional key -> "#"++key++" "++arg++"\n"
388 conditional :: String -> Bool
389 conditional "if" = True
390 conditional "ifdef" = True
391 conditional "ifndef" = True
392 conditional "elif" = True
393 conditional "else" = True
394 conditional "endif" = True
395 conditional "error" = True
396 conditional _ = False
398 sourceFileName :: SourcePos -> String
399 sourceFileName pos = fileName (sourceName pos)
401 fileName s = case break (== '/') s of
403 (_, _:rest) -> fileName rest
405 outCLine :: SourcePos -> String
407 "# "++show (sourceLine pos)++
408 " \""++showCString (sourceFileName pos)++"\"\n"
410 outHsLine :: SourcePos -> String
412 " printf (\"{-# LINE %d \\\"%s\\\" #-}\\n\", "++
413 show (sourceLine pos + 1)++", \""++
414 showCString (sourceFileName pos)++"\");\n"
416 showCString :: String -> String
417 showCString = concatMap showCChar
419 showCChar '\"' = "\\\""
420 showCChar '\'' = "\\\'"
421 showCChar '?' = "\\?"
422 showCChar '\\' = "\\\\"
423 showCChar c | c >= ' ' && c <= '~' = [c]
424 showCChar '\a' = "\\a"
425 showCChar '\b' = "\\b"
426 showCChar '\f' = "\\f"
427 showCChar '\n' = "\\n\"\n \""
428 showCChar '\r' = "\\r"
429 showCChar '\t' = "\\t"
430 showCChar '\v' = "\\v"
432 intToDigit (ord c `quot` 64),
433 intToDigit (ord c `quot` 8 `mod` 8),
434 intToDigit (ord c `mod` 8)]