1 ------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.27 2001/03/29 00:01:18 qrczak Exp $
4 -- Program for converting .hsc files to .hs files, by converting the
5 -- file into a C program which is run to generate the Haskell source.
6 -- Certain items known only to the C compiler can then be used in
7 -- the Haskell module; for example #defined constants, byte offsets
8 -- within structures, etc.
10 -- See the documentation in the Users' Guide for more details.
13 import System (getProgName, getArgs, ExitCode(..), exitWith, exitFailure)
14 import KludgedSystem (system, defaultCompiler)
15 import Directory (removeFile)
16 import Monad (MonadPlus(..), liftM, liftM2, when, unless)
17 import Char (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
18 import List (intersperse)
21 version = "hsc2hs-0.65"
34 include :: String -> Flag
35 include s@('\"':_) = Include s
36 include s@('<' :_) = Include s
37 include s = Include ("\""++s++"\"")
39 options :: [OptDescr Flag]
41 Option "t" ["template"] (ReqArg Template "FILE") "template file",
42 Option "c" ["cc"] (ReqArg Compiler "PROG") "C compiler to use",
43 Option "l" ["ld"] (ReqArg Linker "PROG") "linker to use",
44 Option "C" ["cflag"] (ReqArg CompFlag "FLAG") "flag to pass to the C compiler",
45 Option "I" [] (ReqArg (CompFlag . ("-I"++))
46 "DIR") "passed to the C compiler",
47 Option "L" ["lflag"] (ReqArg LinkFlag "FLAG") "flag to pass to the linker",
48 Option "" ["no-compile"] (NoArg NoCompile) "stop after writing HsMake*.c",
49 Option "i" ["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
76 Parser p -> case p (SourcePos name 1) s of
77 Success _ _ _ toks -> output flags name toks
78 Failure (SourcePos name' line) msg -> do
79 putStrLn (name'++":"++show line++": "++msg)
82 ------------------------------------------------------------------------
83 -- A deterministic parser which remembers the text which has been parsed.
85 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
87 data ParseResult a = Success !SourcePos String String a
88 | Failure !SourcePos String
90 data SourcePos = SourcePos String !Int
92 updatePos :: SourcePos -> Char -> SourcePos
93 updatePos pos@(SourcePos name line) ch = case ch of
94 '\n' -> SourcePos name (line + 1)
97 instance Monad Parser where
98 return a = Parser $ \pos s -> Success pos [] s a
100 Parser $ \pos s -> case m pos s of
101 Success pos' out1 s' a -> case k a of
102 Parser k' -> case k' pos' s' of
103 Success pos'' out2 imp'' b ->
104 Success pos'' (out1++out2) imp'' b
105 Failure pos'' msg -> Failure pos'' msg
106 Failure pos' msg -> Failure pos' msg
107 fail msg = Parser $ \pos _ -> Failure pos msg
109 instance MonadPlus Parser where
111 Parser m `mplus` Parser n =
112 Parser $ \pos s -> case m pos s of
113 success@(Success _ _ _ _) -> success
114 Failure _ _ -> n pos s
116 getPos :: Parser SourcePos
117 getPos = Parser $ \pos s -> Success pos [] s pos
119 setPos :: SourcePos -> Parser ()
120 setPos pos = Parser $ \_ s -> Success pos [] s ()
122 message :: Parser a -> String -> Parser a
123 Parser m `message` msg =
124 Parser $ \pos s -> case m pos s of
125 success@(Success _ _ _ _) -> success
126 Failure pos' _ -> Failure pos' msg
128 catchOutput_ :: Parser a -> Parser String
129 catchOutput_ (Parser m) =
130 Parser $ \pos s -> case m pos s of
131 Success pos' out s' _ -> Success pos' [] s' out
132 Failure pos' msg -> Failure pos' msg
134 fakeOutput :: Parser a -> String -> Parser a
135 Parser m `fakeOutput` out =
136 Parser $ \pos s -> case m pos s of
137 Success pos' _ s' a -> Success pos' out s' a
138 Failure pos' msg -> Failure pos' msg
140 lookAhead :: Parser String
141 lookAhead = Parser $ \pos s -> Success pos [] s s
143 satisfy :: (Char -> Bool) -> Parser Char
145 Parser $ \pos s -> case s of
146 c:cs | p c -> Success (updatePos pos c) [c] cs c
147 _ -> Failure pos "Bad character"
149 char_ :: Char -> Parser ()
151 satisfy (== c) `message` (show c++" expected")
154 anyChar_ :: Parser ()
156 satisfy (const True) `message` "Unexpected end of file"
159 any2Chars_ :: Parser ()
160 any2Chars_ = anyChar_ >> anyChar_
162 many :: Parser a -> Parser [a]
163 many p = many1 p `mplus` return []
165 many1 :: Parser a -> Parser [a]
166 many1 p = liftM2 (:) p (many p)
168 many_ :: Parser a -> Parser ()
169 many_ p = many1_ p `mplus` return ()
171 many1_ :: Parser a -> Parser ()
172 many1_ p = p >> many_ p
174 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
175 manySatisfy = many . satisfy
176 manySatisfy1 = many1 . satisfy
178 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
179 manySatisfy_ = many_ . satisfy
180 manySatisfy1_ = many1_ . satisfy
182 ------------------------------------------------------------------------
183 -- Parser of hsc syntax.
186 = Text SourcePos String
187 | Special SourcePos String String
189 parser :: Parser [Token]
192 t <- catchOutput_ text
196 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
197 return (if null t then rest else Text pos t : rest)
204 c:_ | isAlpha c || c == '_' -> do
206 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
208 c:_ | isHsSymbol c -> do
209 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
212 '-':'-':symb' | all (== '-') symb' -> do
213 return () `fakeOutput` symb
214 manySatisfy_ (/= '\n')
217 return () `fakeOutput` unescapeHashes symb
219 '\"':_ -> do anyChar_; hsString '\"'; text
220 '\'':_ -> do anyChar_; hsString '\''; text
221 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
222 _:_ -> do anyChar_; text
224 hsString :: Char -> Parser ()
229 c:_ | c == quote -> anyChar_
234 char_ '\\' `mplus` return ()
236 | otherwise -> do any2Chars_; hsString quote
237 _:_ -> do anyChar_; hsString quote
239 hsComment :: Parser ()
244 '-':'}':_ -> any2Chars_
245 '{':'-':_ -> do any2Chars_; hsComment; hsComment
246 _:_ -> do anyChar_; hsComment
248 linePragma :: Parser ()
252 satisfy (\c -> c == 'L' || c == 'l')
253 satisfy (\c -> c == 'I' || c == 'i')
254 satisfy (\c -> c == 'N' || c == 'n')
255 satisfy (\c -> c == 'E' || c == 'e')
256 manySatisfy1_ isSpace
257 line <- liftM read $ manySatisfy1 isDigit
258 manySatisfy1_ isSpace
260 name <- manySatisfy (/= '\"')
266 setPos (SourcePos name (line - 1))
268 isHsSymbol :: Char -> Bool
269 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
270 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
271 isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True
272 isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True
273 isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True
274 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
275 isHsSymbol '~' = True
278 unescapeHashes :: String -> String
279 unescapeHashes [] = []
280 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
281 unescapeHashes (c:s) = c : unescapeHashes s
283 lookAheadC :: Parser String
284 lookAheadC = liftM joinLines lookAhead
287 joinLines ('\\':'\n':s) = joinLines s
288 joinLines (c:s) = c : joinLines s
290 satisfyC :: (Char -> Bool) -> Parser Char
294 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
297 charC_ :: Char -> Parser ()
299 satisfyC (== c) `message` (show c++" expected")
302 anyCharC_ :: Parser ()
304 satisfyC (const True) `message` "Unexpected end of file"
307 any2CharsC_ :: Parser ()
308 any2CharsC_ = anyCharC_ >> anyCharC_
310 manySatisfyC :: (Char -> Bool) -> Parser String
311 manySatisfyC = many . satisfyC
313 manySatisfyC_ :: (Char -> Bool) -> Parser ()
314 manySatisfyC_ = many_ . satisfyC
316 special :: Parser Token
318 manySatisfyC_ (\c -> isSpace c && c /= '\n')
323 manySatisfyC_ isSpace
324 sp <- keyArg (== '\n')
327 _ -> keyArg (const False)
329 keyArg :: (Char -> Bool) -> Parser Token
332 key <- keyword `message` "hsc keyword or '{' expected"
333 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
334 arg <- catchOutput_ (argument eol)
335 return (Special pos key arg)
337 keyword :: Parser String
339 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
340 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
343 argument :: (Char -> Bool) -> Parser ()
348 c:_ | eol c -> do anyCharC_; argument eol
350 '\"':_ -> do anyCharC_; cString '\"'; argument eol
351 '\'':_ -> do anyCharC_; cString '\''; argument eol
352 '(':_ -> do anyCharC_; nested ')'; argument eol
354 '/':'*':_ -> do any2CharsC_; cComment; argument eol
356 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
357 '[':_ -> do anyCharC_; nested ']'; argument eol
359 '{':_ -> do anyCharC_; nested '}'; argument eol
361 _:_ -> do anyCharC_; argument eol
363 nested :: Char -> Parser ()
364 nested c = do argument (== '\n'); charC_ c
366 cComment :: Parser ()
371 '*':'/':_ -> do any2CharsC_
372 _:_ -> do anyCharC_; cComment
374 cString :: Char -> Parser ()
379 c:_ | c == quote -> anyCharC_
380 '\\':_:_ -> do any2CharsC_; cString quote
381 _:_ -> do anyCharC_; cString quote
383 ------------------------------------------------------------------------
384 -- Write the output files.
386 splitName :: String -> (String, String)
388 case break (== '/') name of
389 (file, []) -> ([], file)
390 (dir, sep:rest) -> (dir++sep:restDir, restFile)
392 (restDir, restFile) = splitName rest
394 splitExt :: String -> (String, String)
396 case break (== '.') name of
397 (base, []) -> (base, [])
398 (base, sepRest@(sep:rest))
399 | null restExt -> (base, sepRest)
400 | otherwise -> (base++sep:restBase, restExt)
402 (restBase, restExt) = splitExt rest
404 output :: [Flag] -> String -> [Token] -> IO ()
405 output flags name toks = let
406 (dir, file) = splitName name
407 (base, ext) = splitExt file
408 cProgName = dir++"HsMake"++base++".c"
409 oProgName = dir++"HsMake"++base++".o"
410 progName = dir++"HsMake"++base
412 | not (null ext) && last ext == 'c' = dir++base++init ext
413 | ext == ".hs" = dir++base++"_out.hs"
414 | otherwise = dir++base++".hs"
415 outHName = dir++"Hs"++base++".h"
416 outCName = dir++"Hs"++base++".c"
419 | null dir = "./"++progName
420 | otherwise = progName
422 specials = [(pos, key, arg) | Special pos key arg <- toks]
424 needsC = any (\(_, key, _) -> key == "def") specials
427 includeGuard = map fixChar outHName
429 fixChar c | isAlphaNum c = toUpper c
434 compiler <- case [c | Compiler c <- flags] of
437 _ -> onlyOne "compiler"
438 linker <- case [l | Linker l <- flags] of
439 [] -> return defaultCompiler
441 _ -> onlyOne "linker"
443 writeFile cProgName $
444 concat ["#include \""++t++"\"\n" | Template t <- flags]++
445 concat ["#include "++f++"\n" | Include f <- flags]++
446 outHeaderCProg specials++
447 "\nint main (void)\n{\n"++
448 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
449 outHsLine (SourcePos name 0)++
450 concatMap outTokenHs toks++
453 unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess
455 compilerStatus <- system $
458 concat [" "++f | CompFlag f <- flags]++
461 case compilerStatus of
462 e@(ExitFailure _) -> exitWith e
466 linkerStatus <- system $
468 concat [" "++f | LinkFlag f <- flags]++
472 e@(ExitFailure _) -> exitWith e
476 system (execProgName++" >"++outHsName)
479 when needsH $ writeFile outHName $
480 "#ifndef "++includeGuard++"\n\
481 \#define "++includeGuard++"\n\
482 \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
485 \#include <HsFFI.h>\n\
488 \#define HsChar int\n\
490 concat ["#include "++n++"\n" | Include n <- flags]++
491 concatMap outTokenH specials++
494 when needsC $ writeFile outCName $
495 "#include \""++outHName++"\"\n"++
496 concatMap outTokenC specials
498 onlyOne :: String -> IO a
500 putStrLn ("Only one "++what++" may be specified")
503 outHeaderCProg :: [(SourcePos, String, String)] -> String
505 concatMap $ \(pos, key, arg) -> case key of
506 "include" -> outCLine pos++"#include "++arg++"\n"
507 "define" -> outCLine pos++"#define "++arg++"\n"
508 "undef" -> outCLine pos++"#undef "++arg++"\n"
510 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
511 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
513 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
514 "let" -> case break (== '=') arg of
516 (header, _:body) -> case break isSpace header of
519 "#define hsc_"++name++"("++dropWhile isSpace args++") \
520 \printf ("++joinLines body++");\n"
523 joinLines = concat . intersperse " \\\n" . lines
525 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
526 outHeaderHs flags inH toks =
527 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
528 \ printf (\"{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d #-}\\n\", \
529 \__GLASGOW_HASKELL__);\n\
532 concatMap outSpecial toks
534 outSpecial (pos, key, arg) = case key of
535 "include" -> case inH of
536 Nothing -> outOption ("-#include "++arg)
538 "define" -> case inH of
539 Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
541 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
543 goodForOptD arg = case arg of
545 c:_ | isSpace c -> True
548 toOptD arg = case break isSpace arg of
550 (name, _:value) -> name++'=':dropWhile isSpace value
552 outOption ("-#include "++name++"")
553 | name <- case inH of
554 Nothing -> [name | Include name <- flags]
555 Just name -> ["\""++name++"\""]]
556 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
557 showCString s++"\");\n"
559 outTokenHs :: Token -> String
560 outTokenHs (Text pos text) =
561 case break (== '\n') text of
562 (all, []) -> outText all
564 outText (first++"\n")++
568 outText s = " fputs (\""++showCString s++"\", stdout);\n"
569 outTokenHs (Special pos key arg) =
575 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
577 "enum" -> outCLine pos++outEnum arg
578 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
580 outEnum :: String -> String
582 case break (== ',') arg of
584 (t, _:afterT) -> case break (== ',') afterT of
587 enums (_:s) = case break (== ',') s of
589 this = case break (== '=') $ dropWhile isSpace enum of
591 " hsc_enum ("++t++", "++f++", \
592 \hsc_haskellize (\""++name++"\"), "++
595 " hsc_enum ("++t++", "++f++", \
596 \printf (\"%s\", \""++hsName++"\"), "++
601 outTokenH :: (SourcePos, String, String) -> String
602 outTokenH (pos, key, arg) =
604 "include" -> outCLine pos++"#include "++arg++"\n"
605 "define" -> outCLine pos++"#define " ++arg++"\n"
606 "undef" -> outCLine pos++"#undef " ++arg++"\n"
607 "def" -> outCLine pos++case arg of
608 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
609 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
610 'i':'n':'l':'i':'n':'e':' ':_ ->
615 _ -> "extern "++header++";\n"
616 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
617 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
620 outTokenC :: (SourcePos, String, String) -> String
621 outTokenC (pos, key, arg) =
624 's':'t':'r':'u':'c':'t':' ':_ -> ""
625 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
626 'i':'n':'l':'i':'n':'e':' ':_ ->
632 "\n#ifndef __GNUC__\n\
637 _ -> outCLine pos++arg++"\n"
638 where (header, body) = span (\c -> c /= '{' && c /= '=') arg
639 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
642 conditional :: String -> Bool
643 conditional "if" = True
644 conditional "ifdef" = True
645 conditional "ifndef" = True
646 conditional "elif" = True
647 conditional "else" = True
648 conditional "endif" = True
649 conditional "error" = True
650 conditional "warning" = True
651 conditional _ = False
653 outCLine :: SourcePos -> String
654 outCLine (SourcePos name line) =
655 "# "++show line++" \""++showCString (snd (splitName name))++"\"\n"
657 outHsLine :: SourcePos -> String
658 outHsLine (SourcePos name line) =
659 " hsc_line ("++show (line + 1)++", \""++
660 showCString (snd (splitName name))++"\");\n"
662 showCString :: String -> String
663 showCString = concatMap showCChar
665 showCChar '\"' = "\\\""
666 showCChar '\'' = "\\\'"
667 showCChar '?' = "\\?"
668 showCChar '\\' = "\\\\"
669 showCChar c | c >= ' ' && c <= '~' = [c]
670 showCChar '\a' = "\\a"
671 showCChar '\b' = "\\b"
672 showCChar '\f' = "\\f"
673 showCChar '\n' = "\\n\"\n \""
674 showCChar '\r' = "\\r"
675 showCChar '\t' = "\\t"
676 showCChar '\v' = "\\v"
678 intToDigit (ord c `quot` 64),
679 intToDigit (ord c `quot` 8 `mod` 8),
680 intToDigit (ord c `mod` 8)]