1 ------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.32 2001/07/24 05:49:32 ken 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)
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"
33 | Define String (Maybe String)
36 include :: String -> Flag
37 include s@('\"':_) = Include s
38 include s@('<' :_) = Include s
39 include s = Include ("\""++s++"\"")
41 define :: String -> Flag
42 define s = case break (== '=') s of
43 (name, []) -> Define name Nothing
44 (name, _:value) -> Define name (Just value)
46 options :: [OptDescr Flag]
48 Option "t" ["template"] (ReqArg Template "FILE") "template file",
49 Option "c" ["cc"] (ReqArg Compiler "PROG") "C compiler to use",
50 Option "l" ["ld"] (ReqArg Linker "PROG") "linker to use",
51 Option "C" ["cflag"] (ReqArg CompFlag "FLAG") "flag to pass to the C compiler",
52 Option "I" [] (ReqArg (CompFlag . ("-I"++))
53 "DIR") "passed to the C compiler",
54 Option "L" ["lflag"] (ReqArg LinkFlag "FLAG") "flag to pass to the linker",
55 Option "i" ["include"] (ReqArg include "FILE") "as if placed in the source",
56 Option "D" ["define"] (ReqArg define "NAME[=VALUE]") "as if placed in the source",
57 Option "o" ["output"] (ReqArg Output "FILE") "name of main output file",
58 Option "" ["help"] (NoArg Help) "display this help and exit",
59 Option "" ["version"] (NoArg Version) "output version information and exit",
60 Option "" ["no-compile"] (NoArg NoCompile) "stop after writing *_hsc_make.c"]
65 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]"
67 case getOpt Permute options args of
69 | any isHelp flags -> putStrLn (usageInfo header options)
70 | any isVersion flags -> putStrLn version
72 isHelp Help = True; isHelp _ = False
73 isVersion Version = True; isVersion _ = False
74 (_, [], []) -> putStrLn (prog++": No input files")
75 (flags, files, []) -> mapM_ (processFile flags) files
78 putStrLn (usageInfo header options)
81 processFile :: [Flag] -> String -> IO ()
82 processFile flags name = do
85 Parser p -> case p (SourcePos name 1) s of
86 Success _ _ _ toks -> output flags name toks
87 Failure (SourcePos name' line) msg -> do
88 putStrLn (name'++":"++show line++": "++msg)
91 ------------------------------------------------------------------------
92 -- A deterministic parser which remembers the text which has been parsed.
94 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
96 data ParseResult a = Success !SourcePos String String a
97 | Failure !SourcePos String
99 data SourcePos = SourcePos String !Int
101 updatePos :: SourcePos -> Char -> SourcePos
102 updatePos pos@(SourcePos name line) ch = case ch of
103 '\n' -> SourcePos name (line + 1)
106 instance Monad Parser where
107 return a = Parser $ \pos s -> Success pos [] s a
109 Parser $ \pos s -> case m pos s of
110 Success pos' out1 s' a -> case k a of
111 Parser k' -> case k' pos' s' of
112 Success pos'' out2 imp'' b ->
113 Success pos'' (out1++out2) imp'' b
114 Failure pos'' msg -> Failure pos'' msg
115 Failure pos' msg -> Failure pos' msg
116 fail msg = Parser $ \pos _ -> Failure pos msg
118 instance MonadPlus Parser where
120 Parser m `mplus` Parser n =
121 Parser $ \pos s -> case m pos s of
122 success@(Success _ _ _ _) -> success
123 Failure _ _ -> n pos s
125 getPos :: Parser SourcePos
126 getPos = Parser $ \pos s -> Success pos [] s pos
128 setPos :: SourcePos -> Parser ()
129 setPos pos = Parser $ \_ s -> Success pos [] s ()
131 message :: Parser a -> String -> Parser a
132 Parser m `message` msg =
133 Parser $ \pos s -> case m pos s of
134 success@(Success _ _ _ _) -> success
135 Failure pos' _ -> Failure pos' msg
137 catchOutput_ :: Parser a -> Parser String
138 catchOutput_ (Parser m) =
139 Parser $ \pos s -> case m pos s of
140 Success pos' out s' _ -> Success pos' [] s' out
141 Failure pos' msg -> Failure pos' msg
143 fakeOutput :: Parser a -> String -> Parser a
144 Parser m `fakeOutput` out =
145 Parser $ \pos s -> case m pos s of
146 Success pos' _ s' a -> Success pos' out s' a
147 Failure pos' msg -> Failure pos' msg
149 lookAhead :: Parser String
150 lookAhead = Parser $ \pos s -> Success pos [] s s
152 satisfy :: (Char -> Bool) -> Parser Char
154 Parser $ \pos s -> case s of
155 c:cs | p c -> Success (updatePos pos c) [c] cs c
156 _ -> Failure pos "Bad character"
158 char_ :: Char -> Parser ()
160 satisfy (== c) `message` (show c++" expected")
163 anyChar_ :: Parser ()
165 satisfy (const True) `message` "Unexpected end of file"
168 any2Chars_ :: Parser ()
169 any2Chars_ = anyChar_ >> anyChar_
171 many :: Parser a -> Parser [a]
172 many p = many1 p `mplus` return []
174 many1 :: Parser a -> Parser [a]
175 many1 p = liftM2 (:) p (many p)
177 many_ :: Parser a -> Parser ()
178 many_ p = many1_ p `mplus` return ()
180 many1_ :: Parser a -> Parser ()
181 many1_ p = p >> many_ p
183 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
184 manySatisfy = many . satisfy
185 manySatisfy1 = many1 . satisfy
187 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
188 manySatisfy_ = many_ . satisfy
189 manySatisfy1_ = many1_ . satisfy
191 ------------------------------------------------------------------------
192 -- Parser of hsc syntax.
195 = Text SourcePos String
196 | Special SourcePos String String
198 parser :: Parser [Token]
201 t <- catchOutput_ text
205 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
206 return (if null t then rest else Text pos t : rest)
213 c:_ | isAlpha c || c == '_' -> do
215 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
217 c:_ | isHsSymbol c -> do
218 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
221 '-':'-':symb' | all (== '-') symb' -> do
222 return () `fakeOutput` symb
223 manySatisfy_ (/= '\n')
226 return () `fakeOutput` unescapeHashes symb
228 '\"':_ -> do anyChar_; hsString '\"'; text
229 '\'':_ -> do anyChar_; hsString '\''; text
230 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
231 _:_ -> do anyChar_; text
233 hsString :: Char -> Parser ()
238 c:_ | c == quote -> anyChar_
243 char_ '\\' `mplus` return ()
245 | otherwise -> do any2Chars_; hsString quote
246 _:_ -> do anyChar_; hsString quote
248 hsComment :: Parser ()
253 '-':'}':_ -> any2Chars_
254 '{':'-':_ -> do any2Chars_; hsComment; hsComment
255 _:_ -> do anyChar_; hsComment
257 linePragma :: Parser ()
261 satisfy (\c -> c == 'L' || c == 'l')
262 satisfy (\c -> c == 'I' || c == 'i')
263 satisfy (\c -> c == 'N' || c == 'n')
264 satisfy (\c -> c == 'E' || c == 'e')
265 manySatisfy1_ isSpace
266 line <- liftM read $ manySatisfy1 isDigit
267 manySatisfy1_ isSpace
269 name <- manySatisfy (/= '\"')
275 setPos (SourcePos name (line - 1))
277 isHsSymbol :: Char -> Bool
278 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
279 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
280 isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True
281 isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True
282 isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True
283 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
284 isHsSymbol '~' = True
287 unescapeHashes :: String -> String
288 unescapeHashes [] = []
289 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
290 unescapeHashes (c:s) = c : unescapeHashes s
292 lookAheadC :: Parser String
293 lookAheadC = liftM joinLines lookAhead
296 joinLines ('\\':'\n':s) = joinLines s
297 joinLines (c:s) = c : joinLines s
299 satisfyC :: (Char -> Bool) -> Parser Char
303 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
306 charC_ :: Char -> Parser ()
308 satisfyC (== c) `message` (show c++" expected")
311 anyCharC_ :: Parser ()
313 satisfyC (const True) `message` "Unexpected end of file"
316 any2CharsC_ :: Parser ()
317 any2CharsC_ = anyCharC_ >> anyCharC_
319 manySatisfyC :: (Char -> Bool) -> Parser String
320 manySatisfyC = many . satisfyC
322 manySatisfyC_ :: (Char -> Bool) -> Parser ()
323 manySatisfyC_ = many_ . satisfyC
325 special :: Parser Token
327 manySatisfyC_ (\c -> isSpace c && c /= '\n')
332 manySatisfyC_ isSpace
333 sp <- keyArg (== '\n')
336 _ -> keyArg (const False)
338 keyArg :: (Char -> Bool) -> Parser Token
341 key <- keyword `message` "hsc keyword or '{' expected"
342 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
343 arg <- catchOutput_ (argument eol)
344 return (Special pos key arg)
346 keyword :: Parser String
348 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
349 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
352 argument :: (Char -> Bool) -> Parser ()
357 c:_ | eol c -> do anyCharC_; argument eol
359 '\"':_ -> do anyCharC_; cString '\"'; argument eol
360 '\'':_ -> do anyCharC_; cString '\''; argument eol
361 '(':_ -> do anyCharC_; nested ')'; argument eol
363 '/':'*':_ -> do any2CharsC_; cComment; argument eol
365 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
366 '[':_ -> do anyCharC_; nested ']'; argument eol
368 '{':_ -> do anyCharC_; nested '}'; argument eol
370 _:_ -> do anyCharC_; argument eol
372 nested :: Char -> Parser ()
373 nested c = do argument (== '\n'); charC_ c
375 cComment :: Parser ()
380 '*':'/':_ -> do any2CharsC_
381 _:_ -> do anyCharC_; cComment
383 cString :: Char -> Parser ()
388 c:_ | c == quote -> anyCharC_
389 '\\':_:_ -> do any2CharsC_; cString quote
390 _:_ -> do anyCharC_; cString quote
392 ------------------------------------------------------------------------
393 -- Write the output files.
395 splitName :: String -> (String, String)
397 case break (== '/') name of
398 (file, []) -> ([], file)
399 (dir, sep:rest) -> (dir++sep:restDir, restFile)
401 (restDir, restFile) = splitName rest
403 splitExt :: String -> (String, String)
405 case break (== '.') name of
406 (base, []) -> (base, [])
407 (base, sepRest@(sep:rest))
408 | null restExt -> (base, sepRest)
409 | otherwise -> (base++sep:restBase, restExt)
411 (restBase, restExt) = splitExt rest
413 output :: [Flag] -> String -> [Token] -> IO ()
414 output flags name toks = do
416 (outName, outDir, outBase) <- case [f | Output f <- flags] of
419 last ext == 'c' -> return (dir++base++init ext, dir, base)
420 | ext == ".hs" -> return (dir++base++"_out.hs", dir, base)
421 | otherwise -> return (dir++base++".hs", dir, base)
423 (dir, file) = splitName name
424 (base, ext) = splitExt file
426 (dir, file) = splitName f
427 (base, _) = splitExt file
428 in return (f, dir, base)
429 _ -> onlyOne "output file"
431 let cProgName = outDir++outBase++"_hsc_make.c"
432 oProgName = outDir++outBase++"_hsc_make.o"
433 progName = outDir++outBase++"_hsc_make" ++ progNameSuffix
434 outHName = outDir++outBase++"_hsc.h"
435 outCName = outDir++outBase++"_hsc.c"
438 | null outDir = "./"++progName
439 | otherwise = progName
441 let specials = [(pos, key, arg) | Special pos key arg <- toks]
443 let needsC = any (\(_, key, _) -> key == "def") specials
446 let includeGuard = map fixChar outHName
448 fixChar c | isAlphaNum c = toUpper c
451 compiler <- case [c | Compiler c <- flags] of
454 _ -> onlyOne "compiler"
456 linker <- case [l | Linker l <- flags] of
457 [] -> return defaultCompiler
459 _ -> onlyOne "linker"
461 writeFile cProgName $
462 concatMap outFlagHeaderCProg flags++
463 concatMap outHeaderCProg specials++
464 "\nint main (void)\n{\n"++
465 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
466 outHsLine (SourcePos name 0)++
467 concatMap outTokenHs toks++
470 unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess
472 compilerStatus <- system $
475 concat [" "++f | CompFlag f <- flags]++
478 case compilerStatus of
479 e@(ExitFailure _) -> exitWith e
483 linkerStatus <- system $
485 concat [" "++f | LinkFlag f <- flags]++
489 e@(ExitFailure _) -> exitWith e
493 system (execProgName++" >"++outName)
496 when needsH $ writeFile outHName $
497 "#ifndef "++includeGuard++"\n\
498 \#define "++includeGuard++"\n\
499 \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
502 \#include <HsFFI.h>\n\
505 \#define HsChar int\n\
507 concatMap outFlagH flags++
508 concatMap outTokenH specials++
511 when needsC $ writeFile outCName $
512 "#include \""++outHName++"\"\n"++
513 concatMap outTokenC specials
515 onlyOne :: String -> IO a
517 putStrLn ("Only one "++what++" may be specified")
520 outFlagHeaderCProg :: Flag -> String
521 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
522 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
523 outFlagHeaderCProg (Define n Nothing) = "#define "++n++"\n"
524 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
525 outFlagHeaderCProg _ = ""
527 outHeaderCProg :: (SourcePos, String, String) -> String
528 outHeaderCProg (pos, key, arg) = case key of
529 "include" -> outCLine pos++"#include "++arg++"\n"
530 "define" -> outCLine pos++"#define "++arg++"\n"
531 "undef" -> outCLine pos++"#undef "++arg++"\n"
533 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
534 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
536 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
537 "let" -> case break (== '=') arg of
539 (header, _:body) -> case break isSpace header of
542 "#define hsc_"++name++"("++dropWhile isSpace args++") \
543 \printf ("++joinLines body++");\n"
546 joinLines = concat . intersperse " \\\n" . lines
548 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
549 outHeaderHs flags inH toks =
550 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
551 \ printf (\"{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d #-}\\n\", \
552 \__GLASGOW_HASKELL__);\n\
555 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
556 Just f -> outOption ("-#include \""++f++"\"")
558 outFlag (Include f) = outOption ("-#include "++f)
559 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
560 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
562 outSpecial (pos, key, arg) = case key of
563 "include" -> outOption ("-#include "++arg)
564 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
566 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
568 goodForOptD arg = case arg of
570 c:_ | isSpace c -> True
573 toOptD arg = case break isSpace arg of
575 (name, _:value) -> name++'=':dropWhile isSpace value
576 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
577 showCString s++"\");\n"
579 outTokenHs :: Token -> String
580 outTokenHs (Text pos text) =
581 case break (== '\n') text of
582 (all, []) -> outText all
584 outText (first++"\n")++
588 outText s = " fputs (\""++showCString s++"\", stdout);\n"
589 outTokenHs (Special pos key arg) =
595 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
597 "enum" -> outCLine pos++outEnum arg
598 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
600 outEnum :: String -> String
602 case break (== ',') arg of
604 (t, _:afterT) -> case break (== ',') afterT of
607 enums (_:s) = case break (== ',') s of
609 this = case break (== '=') $ dropWhile isSpace enum of
611 " hsc_enum ("++t++", "++f++", \
612 \hsc_haskellize (\""++name++"\"), "++
615 " hsc_enum ("++t++", "++f++", \
616 \printf (\"%s\", \""++hsName++"\"), "++
621 outFlagH :: Flag -> String
622 outFlagH (Include f) = "#include "++f++"\n"
623 outFlagH (Define n Nothing) = "#define "++n++"\n"
624 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
627 outTokenH :: (SourcePos, String, String) -> String
628 outTokenH (pos, key, arg) =
630 "include" -> outCLine pos++"#include "++arg++"\n"
631 "define" -> outCLine pos++"#define " ++arg++"\n"
632 "undef" -> outCLine pos++"#undef " ++arg++"\n"
633 "def" -> outCLine pos++case arg of
634 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
635 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
636 'i':'n':'l':'i':'n':'e':' ':_ ->
641 _ -> "extern "++header++";\n"
642 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
643 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
646 outTokenC :: (SourcePos, String, String) -> String
647 outTokenC (pos, key, arg) =
650 's':'t':'r':'u':'c':'t':' ':_ -> ""
651 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
652 'i':'n':'l':'i':'n':'e':' ':arg' ->
653 case span (\c -> c /= '{' && c /= '=') arg' of
660 "\n#ifndef __GNUC__\n\
665 _ -> outCLine pos++arg++"\n"
666 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
669 conditional :: String -> Bool
670 conditional "if" = True
671 conditional "ifdef" = True
672 conditional "ifndef" = True
673 conditional "elif" = True
674 conditional "else" = True
675 conditional "endif" = True
676 conditional "error" = True
677 conditional "warning" = True
678 conditional _ = False
680 outCLine :: SourcePos -> String
681 outCLine (SourcePos name line) =
682 "# "++show line++" \""++showCString (snd (splitName name))++"\"\n"
684 outHsLine :: SourcePos -> String
685 outHsLine (SourcePos name line) =
686 " hsc_line ("++show (line + 1)++", \""++
687 showCString (snd (splitName name))++"\");\n"
689 showCString :: String -> String
690 showCString = concatMap showCChar
692 showCChar '\"' = "\\\""
693 showCChar '\'' = "\\\'"
694 showCChar '?' = "\\?"
695 showCChar '\\' = "\\\\"
696 showCChar c | c >= ' ' && c <= '~' = [c]
697 showCChar '\a' = "\\a"
698 showCChar '\b' = "\\b"
699 showCChar '\f' = "\\f"
700 showCChar '\n' = "\\n\"\n \""
701 showCChar '\r' = "\\r"
702 showCChar '\t' = "\\t"
703 showCChar '\v' = "\\v"
705 intToDigit (ord c `quot` 64),
706 intToDigit (ord c `quot` 8 `mod` 8),
707 intToDigit (ord c `mod` 8)]