1 ------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.25 2001/03/05 00:07:23 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 *.hs_make.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 {-# INLINE lookAhead #-}
141 lookAhead :: Parser String
142 lookAhead = Parser $ \pos s -> Success pos [] s s
144 {-# INLINE satisfy #-}
145 satisfy :: (Char -> Bool) -> Parser Char
147 Parser $ \pos s -> case s of
148 c:cs | p c -> Success (updatePos pos c) [c] cs c
149 _ -> Failure pos "Bad character"
151 char_ :: Char -> Parser ()
153 satisfy (== c) `message` (show c++" expected")
156 anyChar_ :: Parser ()
158 satisfy (const True) `message` "Unexpected end of file"
161 any2Chars_ :: Parser ()
162 any2Chars_ = anyChar_ >> anyChar_
164 many :: Parser a -> Parser [a]
165 many p = many1 p `mplus` return []
167 many1 :: Parser a -> Parser [a]
168 many1 p = liftM2 (:) p (many p)
170 many_ :: Parser a -> Parser ()
171 many_ p = many1_ p `mplus` return ()
173 many1_ :: Parser a -> Parser ()
174 many1_ p = p >> many_ p
176 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
177 manySatisfy = many . satisfy
178 manySatisfy1 = many1 . satisfy
180 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
181 manySatisfy_ = many_ . satisfy
182 manySatisfy1_ = many1_ . satisfy
184 ------------------------------------------------------------------------
185 -- Parser of hsc syntax.
188 = Text SourcePos String
189 | Special SourcePos String String
191 parser :: Parser [Token]
194 t <- catchOutput_ text
198 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
199 return (if null t then rest else Text pos t : rest)
206 c:_ | isAlpha c || c == '_' -> do
208 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
210 c:_ | isHsSymbol c -> do
211 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
214 '-':'-':symb' | all (== '-') symb' -> do
215 return () `fakeOutput` symb
216 manySatisfy_ (/= '\n')
219 return () `fakeOutput` unescapeHashes symb
221 '\"':_ -> do anyChar_; hsString '\"'; text
222 '\'':_ -> do anyChar_; hsString '\''; text
223 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
224 _:_ -> do anyChar_; text
226 hsString :: Char -> Parser ()
231 c:_ | c == quote -> anyChar_
236 char_ '\\' `mplus` return ()
238 | otherwise -> do any2Chars_; hsString quote
239 _:_ -> do anyChar_; hsString quote
241 hsComment :: Parser ()
246 '-':'}':_ -> any2Chars_
247 '{':'-':_ -> do any2Chars_; hsComment; hsComment
248 _:_ -> do anyChar_; hsComment
250 linePragma :: Parser ()
254 satisfy (\c -> c == 'L' || c == 'l')
255 satisfy (\c -> c == 'I' || c == 'i')
256 satisfy (\c -> c == 'N' || c == 'n')
257 satisfy (\c -> c == 'E' || c == 'e')
258 manySatisfy1_ isSpace
259 line <- liftM read $ manySatisfy1 isDigit
260 manySatisfy1_ isSpace
262 name <- manySatisfy (/= '\"')
268 setPos (SourcePos name (line - 1))
270 isHsSymbol :: Char -> Bool
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; isHsSymbol '@' = True; isHsSymbol '\\' = True
276 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
277 isHsSymbol '~' = True
280 unescapeHashes :: String -> String
281 unescapeHashes [] = []
282 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
283 unescapeHashes (c:s) = c : unescapeHashes s
285 {-# INLINE lookAheadC #-}
286 lookAheadC :: Parser String
287 lookAheadC = liftM joinLines lookAhead
290 joinLines ('\\':'\n':s) = joinLines s
291 joinLines (c:s) = c : joinLines s
293 {-# INLINE satisfyC #-}
294 satisfyC :: (Char -> Bool) -> Parser Char
298 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
301 charC_ :: Char -> Parser ()
303 satisfyC (== c) `message` (show c++" expected")
306 anyCharC_ :: Parser ()
308 satisfyC (const True) `message` "Unexpected end of file"
311 any2CharsC_ :: Parser ()
312 any2CharsC_ = anyCharC_ >> anyCharC_
314 manySatisfyC :: (Char -> Bool) -> Parser String
315 manySatisfyC = many . satisfyC
317 manySatisfyC_ :: (Char -> Bool) -> Parser ()
318 manySatisfyC_ = many_ . satisfyC
320 special :: Parser Token
322 manySatisfyC_ (\c -> isSpace c && c /= '\n')
327 manySatisfyC_ isSpace
328 sp <- keyArg (== '\n')
331 _ -> keyArg (const False)
333 keyArg :: (Char -> Bool) -> Parser Token
336 key <- keyword `message` "hsc keyword or '{' expected"
337 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
338 arg <- catchOutput_ (argument eol)
339 return (Special pos key arg)
341 keyword :: Parser String
343 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
344 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
347 argument :: (Char -> Bool) -> Parser ()
352 c:_ | eol c -> do anyCharC_; argument eol
354 '\"':_ -> do anyCharC_; cString '\"'; argument eol
355 '\'':_ -> do anyCharC_; cString '\''; argument eol
356 '(':_ -> do anyCharC_; nested ')'; argument eol
358 '/':'*':_ -> do any2CharsC_; cComment; argument eol
360 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
361 '[':_ -> do anyCharC_; nested ']'; argument eol
363 '{':_ -> do anyCharC_; nested '}'; argument eol
365 _:_ -> do anyCharC_; argument eol
367 nested :: Char -> Parser ()
368 nested c = do argument (== '\n'); charC_ c
370 cComment :: Parser ()
375 '*':'/':_ -> do any2CharsC_
376 _:_ -> do anyCharC_; cComment
378 cString :: Char -> Parser ()
383 c:_ | c == quote -> anyCharC_
384 '\\':_:_ -> do any2CharsC_; cString quote
385 _:_ -> do anyCharC_; cString quote
387 ------------------------------------------------------------------------
388 -- Output the output files.
390 output :: [Flag] -> String -> [Token] -> IO ()
391 output flags name toks = let
392 baseName = case reverse name of
393 'c':base -> reverse base
395 cProgName = baseName++"_make.c"
396 oProgName = baseName++"_make.o"
397 progName = baseName++"_make"
399 outHName = baseName++".h"
400 outCName = baseName++".c"
402 execProgName = case progName of
406 specials = [(pos, key, arg) | Special pos key arg <- toks]
408 needsC = any (\(_, key, _) -> key == "def") specials
411 includeGuard = map fixChar outHName
413 fixChar c | isAlphaNum c = toUpper c
418 compiler <- case [c | Compiler c <- flags] of
421 _ -> onlyOne "compiler"
422 linker <- case [l | Linker l <- flags] of
423 [] -> return defaultCompiler
425 _ -> onlyOne "linker"
427 writeFile cProgName $
428 concat ["#include \""++t++"\"\n" | Template t <- flags]++
429 concat ["#include "++f++"\n" | Include f <- flags]++
430 outHeaderCProg specials++
431 "\nint main (void)\n{\n"++
432 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
433 outHsLine (SourcePos name 0)++
434 concatMap outTokenHs toks++
437 unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess
439 compilerStatus <- system $
442 concat [" "++f | CompFlag f <- flags]++
445 case compilerStatus of
446 e@(ExitFailure _) -> exitWith e
450 linkerStatus <- system $
452 concat [" "++f | LinkFlag f <- flags]++
456 e@(ExitFailure _) -> exitWith e
460 system (execProgName++" >"++outHsName)
463 when needsH $ writeFile outHName $
464 "#ifndef "++includeGuard++"\n\
465 \#define "++includeGuard++"\n\
466 \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
469 \#include <HsFFI.h>\n\
472 \#define HsChar int\n\
474 concat ["#include "++n++"\n" | Include n <- flags]++
475 concatMap outTokenH specials++
478 when needsC $ writeFile outCName $
479 "#include \""++outHName++"\"\n"++
480 concatMap outTokenC specials
482 onlyOne :: String -> IO a
484 putStrLn ("Only one "++what++" may be specified")
487 outHeaderCProg :: [(SourcePos, String, String)] -> String
489 concatMap $ \(pos, key, arg) -> case key of
490 "include" -> outCLine pos++"#include "++arg++"\n"
491 "define" -> outCLine pos++"#define "++arg++"\n"
492 "undef" -> outCLine pos++"#undef "++arg++"\n"
494 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
495 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
497 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
498 "let" -> case break (== '=') arg of
500 (header, _:body) -> case break isSpace header of
503 "#define hsc_"++name++"("++dropWhile isSpace args++") \
504 \printf ("++joinLines body++");\n"
507 joinLines = concat . intersperse " \\\n" . lines
509 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
510 outHeaderHs flags inH toks =
511 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
512 \ printf (\"{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d #-}\\n\", \
513 \__GLASGOW_HASKELL__);\n\
516 concatMap outSpecial toks
518 outSpecial (pos, key, arg) = case key of
519 "include" -> case inH of
520 Nothing -> outOption ("-#include "++arg)
522 "define" -> case inH of
523 Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
525 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
527 goodForOptD arg = case arg of
529 c:_ | isSpace c -> True
532 toOptD arg = case break isSpace arg of
534 (name, _:value) -> name++'=':dropWhile isSpace value
536 outOption ("-#include "++name++"")
537 | name <- case inH of
538 Nothing -> [name | Include name <- flags]
539 Just name -> ["\""++name++"\""]]
540 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
541 showCString s++"\");\n"
543 outTokenHs :: Token -> String
544 outTokenHs (Text pos text) =
545 case break (== '\n') text of
546 (all, []) -> outText all
548 outText (first++"\n")++
552 outText s = " fputs (\""++showCString s++"\", stdout);\n"
553 outTokenHs (Special pos key arg) =
559 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
561 "enum" -> outCLine pos++outEnum arg
562 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
564 outEnum :: String -> String
566 case break (== ',') arg of
568 (t, _:afterT) -> case break (== ',') afterT of
571 enums (_:s) = case break (== ',') s of
573 this = case break (== '=') $ dropWhile isSpace enum of
575 " hsc_enum ("++t++", "++f++", \
576 \hsc_haskellize (\""++name++"\"), "++
579 " hsc_enum ("++t++", "++f++", \
580 \printf (\"%s\", \""++hsName++"\"), "++
585 outTokenH :: (SourcePos, String, String) -> String
586 outTokenH (pos, key, arg) =
588 "include" -> outCLine pos++"#include "++arg++"\n"
589 "define" -> outCLine pos++"#define " ++arg++"\n"
590 "undef" -> outCLine pos++"#undef " ++arg++"\n"
591 "def" -> outCLine pos++case arg of
592 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
593 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
594 'i':'n':'l':'i':'n':'e':' ':_ ->
599 _ -> "extern "++header++";\n"
600 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
601 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
604 outTokenC :: (SourcePos, String, String) -> String
605 outTokenC (pos, key, arg) =
608 's':'t':'r':'u':'c':'t':' ':_ -> ""
609 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
610 'i':'n':'l':'i':'n':'e':' ':_ ->
616 "\n#ifndef __GNUC__\n\
621 _ -> outCLine pos++arg++"\n"
622 where (header, body) = span (\c -> c /= '{' && c /= '=') arg
623 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
626 conditional :: String -> Bool
627 conditional "if" = True
628 conditional "ifdef" = True
629 conditional "ifndef" = True
630 conditional "elif" = True
631 conditional "else" = True
632 conditional "endif" = True
633 conditional "error" = True
634 conditional "warning" = True
635 conditional _ = False
637 outCLine :: SourcePos -> String
638 outCLine (SourcePos name line) =
639 "# "++show line++" \""++showCString (basename name)++"\"\n"
641 outHsLine :: SourcePos -> String
642 outHsLine (SourcePos name line) =
643 " hsc_line ("++show (line + 1)++", \""++
644 showCString (basename name)++"\");\n"
646 basename :: String -> String
647 basename s = case break (== '/') s of
649 (_, _:rest) -> basename rest
651 showCString :: String -> String
652 showCString = concatMap showCChar
654 showCChar '\"' = "\\\""
655 showCChar '\'' = "\\\'"
656 showCChar '?' = "\\?"
657 showCChar '\\' = "\\\\"
658 showCChar c | c >= ' ' && c <= '~' = [c]
659 showCChar '\a' = "\\a"
660 showCChar '\b' = "\\b"
661 showCChar '\f' = "\\f"
662 showCChar '\n' = "\\n\"\n \""
663 showCChar '\r' = "\\r"
664 showCChar '\t' = "\\t"
665 showCChar '\v' = "\\v"
667 intToDigit (ord c `quot` 64),
668 intToDigit (ord c `quot` 8 `mod` 8),
669 intToDigit (ord c `mod` 8)]