1 -----------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.9 2001/01/13 12:11:00 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, isAlpha, isAlphaNum, toUpper)
20 import List (intersperse)
23 version = "hsc2hs-0.64"
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 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 -> do print err; exitFailure
77 Right toks -> output flags name toks
81 | Special String String
83 parser :: Parser [Token]
84 parser = many (text <|> special)
88 liftM (Text . concat) $ many1
89 ( many1 (satisfy (\ch -> not (isAlpha ch || ch `elem` "\"#'-_{")))
90 <|> (do a <- satisfy (\ch -> isAlpha ch || ch == '_')
91 b <- many (satisfy (\ch -> isAlphaNum ch || ch == '_' || ch == '\''))
93 <|> (do char '\"'; a <- hsString '\"'; char '\"'; return ("\""++a++"\""))
94 <|> (do try (string "##"); return "#")
95 <|> (do char '\''; a <- hsString '\''; char '\''; return ("\'"++a++"\'"))
96 <|> (do try (string "--"); a <- many (satisfy (/= '\n')); return ("--"++a))
98 <|> (do try (string "{-"); a <- hsComment; return ("{-"++a))
100 <?> "Haskell source")
102 hsComment :: Parser String
104 ( (do a <- many1 (noneOf "-{"); b <- hsComment; return (a++b))
105 <|> try (string "-}")
106 <|> (do char '-'; b <- hsComment; return ('-':b))
107 <|> (do try (string "{-"); a <- hsComment; b <- hsComment; return ("{-"++a++b))
108 <|> (do char '{'; b <- hsComment; return ('{':b))
109 <?> "Haskell comment")
111 hsString :: Char -> Parser String
114 ( many1 (noneOf (quote:"\n\\"))
115 <|> (do char '\\'; a <- escape; return ('\\':a))
116 <?> "Haskell character or string")
118 escape = (do a <- many1 (satisfy isSpace); char '\\'; return (a++"\\"))
119 <|> (do a <- anyChar; return [a])
121 special :: Parser Token
124 skipMany (oneOf " \t")
125 key <- liftM2 (:) (letter <|> char '_') (many (alphaNum <|> char '_'))
127 skipMany (oneOf " \t")
128 arg <- argument pzero
129 return (Special key arg)
131 argument :: Parser String -> Parser String
134 ( many1 (noneOf "\n\"\'()/[\\]{}")
136 <|> (do char '\"'; a <- cString '\"'; char '\"'; return ("\""++a++"\""))
137 <|> (do char '\''; a <- cString '\''; char '\''; return ("\'"++a++"\'"))
138 <|> (do char '('; a <- nested; char ')'; return ("("++a++")"))
139 <|> (do try (string "/*"); cComment; return " ")
140 <|> (do try (string "//"); skipMany (satisfy (/= '\n')); return " ")
142 <|> (do char '['; a <- nested; char ']'; return ("["++a++"]"))
143 <|> (do char '\\'; a <- anyChar; return $ if a == '\n' then [] else ['\\',a])
144 <|> (do char '{'; a <- nested; char '}'; return ("{"++a++"}"))
146 where nested = argument (string "\n")
148 cComment :: Parser ()
150 ( (do skipMany1 (noneOf "*"); cComment)
151 <|> (do try (string "*/"); return ())
152 <|> (do char '*'; cComment)
155 cString :: Char -> Parser String
158 ( many1 (noneOf (quote:"\n\\"))
159 <|> (do char '\\'; a <- anyChar; return ['\\',a])
160 <?> "C character or string")
162 output :: [Flag] -> String -> [Token] -> IO ()
163 output flags name toks = let
164 baseName = case reverse name of
165 'c':base -> reverse base
167 cProgName = baseName++"c_make_hs.c"
168 oProgName = baseName++"c_make_hs.o"
169 progName = baseName++"c_make_hs"
171 outHName = baseName++".h"
172 outCName = baseName++".c"
174 execProgName = case progName of
178 specials = [(key, arg) | Special key arg <- toks]
180 needsC = any (\(key, _) -> key == "def") specials
183 includeGuard = map fixChar outHName
185 fixChar c | isAlphaNum c = toUpper c
190 compiler <- case [c | Compiler c <- flags] of
193 _ -> onlyOne "compiler"
194 linker <- case [l | Linker l <- flags] of
197 _ -> onlyOne "linker"
199 writeFile cProgName $
200 concat ["#include \""++t++"\"\n" | Template t <- flags]++
201 concat ["#include "++f++"\n" | Include f <- flags]++
202 outHeaderCProg specials++
203 "\nint main (void)\n{\n"++
204 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
205 concatMap outTokenHs toks++
208 compilerStatus <- system $
211 concat [" "++f | CompFlag f <- flags]++
214 case compilerStatus of
215 e@(ExitFailure _) -> exitWith e
219 linkerStatus <- system $
221 concat [" "++f | LinkFlag f <- flags]++
225 e@(ExitFailure _) -> exitWith e
229 system (execProgName++" >"++outHsName)
232 when needsH $ writeFile outHName $
233 "#ifndef "++includeGuard++"\n\
234 \#define "++includeGuard++"\n\
235 \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
238 \#include <HsFFI.h>\n"++
239 concat ["#include "++n++"\n" | Include n <- flags]++
240 concatMap outTokenH specials++
243 when needsC $ writeFile outCName $
244 "#include \""++outHName++"\"\n"++
245 concatMap outTokenC specials
247 onlyOne :: String -> IO a
249 putStrLn ("Only one "++what++" may be specified")
252 outHeaderCProg :: [(String, String)] -> String
253 outHeaderCProg = concatMap $ \(key, arg) -> case key of
254 "include" -> "#include "++arg++"\n"
255 "define" -> "#define "++arg++"\n"
256 "undef" -> "#undef "++arg++"\n"
258 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
259 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
261 _ | conditional key -> "#"++key++" "++arg++"\n"
262 "let" -> case break (== '=') arg of
264 (header, _:body) -> case break isSpace header of
266 "#define hsc_"++name++"("++dropWhile isSpace args++") \
267 \printf ("++joinLines body++");\n"
270 joinLines = concat . intersperse " \\\n" . lines
272 outHeaderHs :: [Flag] -> Maybe String -> [(String, String)] -> String
273 outHeaderHs flags inH toks =
274 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
275 \ printf (\"{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d #-}\\n\", \
276 \__GLASGOW_HASKELL__);\n\
279 concatMap outSpecial toks
281 outSpecial (key, arg) = case key of
282 "include" -> case inH of
283 Nothing -> outOption ("-#include "++arg)
285 "define" -> case inH of
286 Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
288 _ | conditional key -> "#"++key++" "++arg++"\n"
290 goodForOptD arg = case arg of
292 c:_ | isSpace c -> True
295 toOptD arg = case break isSpace arg of
297 (name, _:value) -> name++'=':dropWhile isSpace value
299 outOption ("-#include "++name++"")
300 | name <- case inH of
301 Nothing -> [name | Include name <- flags]
302 Just name -> ["\""++name++"\""]]
303 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
304 showCString s++"\");\n"
306 outTokenHs :: Token -> String
307 outTokenHs (Text s) = " fputs (\""++showCString s++"\", stdout);\n"
308 outTokenHs (Special key arg) = case key of
313 _ | conditional key -> "#"++key++" "++arg++"\n"
315 _ -> " hsc_"++key++" ("++arg++");\n"
317 outTokenH :: (String, String) -> String
318 outTokenH (key, arg) = case key of
319 "include" -> "#include "++arg++"\n"
320 "define" -> "#define " ++arg++"\n"
321 "undef" -> "#undef " ++arg++"\n"
323 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
324 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
325 'i':'n':'l':'i':'n':'e':' ':_ ->
330 _ -> "extern "++header++";\n"
331 where header = takeWhile (\c -> c/='{' && c/='=') arg
332 _ | conditional key -> "#"++key++" "++arg++"\n"
335 outTokenC :: (String, String) -> String
336 outTokenC (key, arg) = case key of
338 's':'t':'r':'u':'c':'t':' ':_ -> ""
339 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
340 'i':'n':'l':'i':'n':'e':' ':_ ->
345 "\n#ifndef __GNUC__\n\
351 where (header, body) = span (\c -> c/='{' && c/='=') arg
352 _ | conditional key -> "#"++key++" "++arg++"\n"
355 conditional :: String -> Bool
356 conditional "if" = True
357 conditional "ifdef" = True
358 conditional "ifndef" = True
359 conditional "elif" = True
360 conditional "else" = True
361 conditional "endif" = True
362 conditional "error" = True
363 conditional _ = False
365 showCString :: String -> String
366 showCString = concatMap showCChar
368 showCChar '\"' = "\\\""
369 showCChar '\'' = "\\\'"
370 showCChar '?' = "\\?"
371 showCChar '\\' = "\\\\"
372 showCChar c | c >= ' ' && c <= '~' = [c]
373 showCChar '\a' = "\\a"
374 showCChar '\b' = "\\b"
375 showCChar '\f' = "\\f"
376 showCChar '\n' = "\\n\"\n \""
377 showCChar '\r' = "\\r"
378 showCChar '\t' = "\\t"
379 showCChar '\v' = "\\v"
381 intToDigit (ord c `quot` 64),
382 intToDigit (ord c `quot` 8 `mod` 8),
383 intToDigit (ord c `mod` 8)]