1 ------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.40 2002/09/09 11:39:42 simonmar 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.
12 #if __GLASGOW_HASKELL__ >= 504
13 import System.Console.GetOpt
19 import System (getProgName, getArgs, ExitCode(..), exitWith, exitFailure, system)
20 import Directory (removeFile)
21 import Monad (MonadPlus(..), liftM, liftM2, when, unless)
22 import Char (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
23 import List (intersperse)
25 #include "../../includes/config.h"
27 #ifdef mingw32_HOST_OS
32 version = "hsc2hs-0.65"
44 | Define String (Maybe String)
47 include :: String -> Flag
48 include s@('\"':_) = Include s
49 include s@('<' :_) = Include s
50 include s = Include ("\""++s++"\"")
52 define :: String -> Flag
53 define s = case break (== '=') s of
54 (name, []) -> Define name Nothing
55 (name, _:value) -> Define name (Just value)
57 options :: [OptDescr Flag]
59 Option "t" ["template"] (ReqArg Template "FILE") "template file",
60 Option "c" ["cc"] (ReqArg Compiler "PROG") "C compiler to use",
61 Option "l" ["ld"] (ReqArg Linker "PROG") "linker to use",
62 Option "C" ["cflag"] (ReqArg CompFlag "FLAG") "flag to pass to the C compiler",
63 Option "I" [] (ReqArg (CompFlag . ("-I"++))
64 "DIR") "passed to the C compiler",
65 Option "L" ["lflag"] (ReqArg LinkFlag "FLAG") "flag to pass to the linker",
66 Option "i" ["include"] (ReqArg include "FILE") "as if placed in the source",
67 Option "D" ["define"] (ReqArg define "NAME[=VALUE]") "as if placed in the source",
68 Option "o" ["output"] (ReqArg Output "FILE") "name of main output file",
69 Option "" ["help"] (NoArg Help) "display this help and exit",
70 Option "" ["version"] (NoArg Version) "output version information and exit",
71 Option "" ["no-compile"] (NoArg NoCompile) "stop after writing *_hsc_make.c"]
76 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]"
78 let opts@(flags, files, errs) = getOpt Permute options args
79 #ifdef mingw32_HOST_OS
80 h <- getModuleHandle Nothing
81 n <- getModuleFileName h
82 let tempName = reverse (drop (length "\\bin\\hsc2hs.exe") (reverse n)) ++ "\\template-hsc.h"
83 let fflags = if [t | Template t <- flags] /= [] then flags else (Template tempName) : flags
84 let opts = (fflags, files, errs)
88 | any isHelp flags -> putStrLn (usageInfo header options)
89 | any isVersion flags -> putStrLn version
91 isHelp Help = True; isHelp _ = False
92 isVersion Version = True; isVersion _ = False
93 (_, [], []) -> putStrLn (prog++": No input files")
94 (flags, files, []) -> mapM_ (processFile flags) files
97 putStrLn (usageInfo header options)
100 processFile :: [Flag] -> String -> IO ()
101 processFile flags name
102 = do let file_name = dosifyPath name
103 s <- readFile file_name
105 Parser p -> case p (SourcePos file_name 1) s of
106 Success _ _ _ toks -> output flags file_name toks
107 Failure (SourcePos name' line) msg -> do
108 putStrLn (name'++":"++show line++": "++msg)
111 ------------------------------------------------------------------------
112 -- Convert paths foo/baz to foo\baz on Windows
114 #if defined(mingw32_HOST_OS)
115 subst a b ls = map (\ x -> if x == a then b else x) ls
116 dosifyPath xs = subst '/' '\\' xs
121 ------------------------------------------------------------------------
122 -- A deterministic parser which remembers the text which has been parsed.
124 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
126 data ParseResult a = Success !SourcePos String String a
127 | Failure !SourcePos String
129 data SourcePos = SourcePos String !Int
131 updatePos :: SourcePos -> Char -> SourcePos
132 updatePos pos@(SourcePos name line) ch = case ch of
133 '\n' -> SourcePos name (line + 1)
136 instance Monad Parser where
137 return a = Parser $ \pos s -> Success pos [] s a
139 Parser $ \pos s -> case m pos s of
140 Success pos' out1 s' a -> case k a of
141 Parser k' -> case k' pos' s' of
142 Success pos'' out2 imp'' b ->
143 Success pos'' (out1++out2) imp'' b
144 Failure pos'' msg -> Failure pos'' msg
145 Failure pos' msg -> Failure pos' msg
146 fail msg = Parser $ \pos _ -> Failure pos msg
148 instance MonadPlus Parser where
150 Parser m `mplus` Parser n =
151 Parser $ \pos s -> case m pos s of
152 success@(Success _ _ _ _) -> success
153 Failure _ _ -> n pos s
155 getPos :: Parser SourcePos
156 getPos = Parser $ \pos s -> Success pos [] s pos
158 setPos :: SourcePos -> Parser ()
159 setPos pos = Parser $ \_ s -> Success pos [] s ()
161 message :: Parser a -> String -> Parser a
162 Parser m `message` msg =
163 Parser $ \pos s -> case m pos s of
164 success@(Success _ _ _ _) -> success
165 Failure pos' _ -> Failure pos' msg
167 catchOutput_ :: Parser a -> Parser String
168 catchOutput_ (Parser m) =
169 Parser $ \pos s -> case m pos s of
170 Success pos' out s' _ -> Success pos' [] s' out
171 Failure pos' msg -> Failure pos' msg
173 fakeOutput :: Parser a -> String -> Parser a
174 Parser m `fakeOutput` out =
175 Parser $ \pos s -> case m pos s of
176 Success pos' _ s' a -> Success pos' out s' a
177 Failure pos' msg -> Failure pos' msg
179 lookAhead :: Parser String
180 lookAhead = Parser $ \pos s -> Success pos [] s s
182 satisfy :: (Char -> Bool) -> Parser Char
184 Parser $ \pos s -> case s of
185 c:cs | p c -> Success (updatePos pos c) [c] cs c
186 _ -> Failure pos "Bad character"
188 char_ :: Char -> Parser ()
190 satisfy (== c) `message` (show c++" expected")
193 anyChar_ :: Parser ()
195 satisfy (const True) `message` "Unexpected end of file"
198 any2Chars_ :: Parser ()
199 any2Chars_ = anyChar_ >> anyChar_
201 many :: Parser a -> Parser [a]
202 many p = many1 p `mplus` return []
204 many1 :: Parser a -> Parser [a]
205 many1 p = liftM2 (:) p (many p)
207 many_ :: Parser a -> Parser ()
208 many_ p = many1_ p `mplus` return ()
210 many1_ :: Parser a -> Parser ()
211 many1_ p = p >> many_ p
213 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
214 manySatisfy = many . satisfy
215 manySatisfy1 = many1 . satisfy
217 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
218 manySatisfy_ = many_ . satisfy
219 manySatisfy1_ = many1_ . satisfy
221 ------------------------------------------------------------------------
222 -- Parser of hsc syntax.
225 = Text SourcePos String
226 | Special SourcePos String String
228 parser :: Parser [Token]
231 t <- catchOutput_ text
235 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
236 return (if null t then rest else Text pos t : rest)
243 c:_ | isAlpha c || c == '_' -> do
245 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
247 c:_ | isHsSymbol c -> do
248 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
251 '-':'-':symb' | all (== '-') symb' -> do
252 return () `fakeOutput` symb
253 manySatisfy_ (/= '\n')
256 return () `fakeOutput` unescapeHashes symb
258 '\"':_ -> do anyChar_; hsString '\"'; text
259 '\'':_ -> do anyChar_; hsString '\''; text
260 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
261 _:_ -> do anyChar_; text
263 hsString :: Char -> Parser ()
268 c:_ | c == quote -> anyChar_
273 char_ '\\' `mplus` return ()
275 | otherwise -> do any2Chars_; hsString quote
276 _:_ -> do anyChar_; hsString quote
278 hsComment :: Parser ()
283 '-':'}':_ -> any2Chars_
284 '{':'-':_ -> do any2Chars_; hsComment; hsComment
285 _:_ -> do anyChar_; hsComment
287 linePragma :: Parser ()
291 satisfy (\c -> c == 'L' || c == 'l')
292 satisfy (\c -> c == 'I' || c == 'i')
293 satisfy (\c -> c == 'N' || c == 'n')
294 satisfy (\c -> c == 'E' || c == 'e')
295 manySatisfy1_ isSpace
296 line <- liftM read $ manySatisfy1 isDigit
297 manySatisfy1_ isSpace
299 name <- manySatisfy (/= '\"')
305 setPos (SourcePos name (line - 1))
307 isHsSymbol :: Char -> Bool
308 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
309 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
310 isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True
311 isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True
312 isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True
313 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
314 isHsSymbol '~' = True
317 unescapeHashes :: String -> String
318 unescapeHashes [] = []
319 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
320 unescapeHashes (c:s) = c : unescapeHashes s
322 lookAheadC :: Parser String
323 lookAheadC = liftM joinLines lookAhead
326 joinLines ('\\':'\n':s) = joinLines s
327 joinLines (c:s) = c : joinLines s
329 satisfyC :: (Char -> Bool) -> Parser Char
333 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
336 charC_ :: Char -> Parser ()
338 satisfyC (== c) `message` (show c++" expected")
341 anyCharC_ :: Parser ()
343 satisfyC (const True) `message` "Unexpected end of file"
346 any2CharsC_ :: Parser ()
347 any2CharsC_ = anyCharC_ >> anyCharC_
349 manySatisfyC :: (Char -> Bool) -> Parser String
350 manySatisfyC = many . satisfyC
352 manySatisfyC_ :: (Char -> Bool) -> Parser ()
353 manySatisfyC_ = many_ . satisfyC
355 special :: Parser Token
357 manySatisfyC_ (\c -> isSpace c && c /= '\n')
362 manySatisfyC_ isSpace
363 sp <- keyArg (== '\n')
366 _ -> keyArg (const False)
368 keyArg :: (Char -> Bool) -> Parser Token
371 key <- keyword `message` "hsc keyword or '{' expected"
372 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
373 arg <- catchOutput_ (argument eol)
374 return (Special pos key arg)
376 keyword :: Parser String
378 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
379 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
382 argument :: (Char -> Bool) -> Parser ()
387 c:_ | eol c -> do anyCharC_; argument eol
389 '\"':_ -> do anyCharC_; cString '\"'; argument eol
390 '\'':_ -> do anyCharC_; cString '\''; argument eol
391 '(':_ -> do anyCharC_; nested ')'; argument eol
393 '/':'*':_ -> do any2CharsC_; cComment; argument eol
395 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
396 '[':_ -> do anyCharC_; nested ']'; argument eol
398 '{':_ -> do anyCharC_; nested '}'; argument eol
400 _:_ -> do anyCharC_; argument eol
402 nested :: Char -> Parser ()
403 nested c = do argument (== '\n'); charC_ c
405 cComment :: Parser ()
410 '*':'/':_ -> do any2CharsC_
411 _:_ -> do anyCharC_; cComment
413 cString :: Char -> Parser ()
418 c:_ | c == quote -> anyCharC_
419 '\\':_:_ -> do any2CharsC_; cString quote
420 _:_ -> do anyCharC_; cString quote
422 ------------------------------------------------------------------------
423 -- Write the output files.
425 splitName :: String -> (String, String)
427 case break (== '/') name of
428 (file, []) -> ([], file)
429 (dir, sep:rest) -> (dir++sep:restDir, restFile)
431 (restDir, restFile) = splitName rest
433 splitExt :: String -> (String, String)
435 case break (== '.') name of
436 (base, []) -> (base, [])
437 (base, sepRest@(sep:rest))
438 | null restExt -> (base, sepRest)
439 | otherwise -> (base++sep:restBase, restExt)
441 (restBase, restExt) = splitExt rest
443 output :: [Flag] -> String -> [Token] -> IO ()
444 output flags name toks = do
446 (outName, outDir, outBase) <- case [f | Output f <- flags] of
449 last ext == 'c' -> return (dir++base++init ext, dir, base)
450 | ext == ".hs" -> return (dir++base++"_out.hs", dir, base)
451 | otherwise -> return (dir++base++".hs", dir, base)
453 (dir, file) = splitName name
454 (base, ext) = splitExt file
456 (dir, file) = splitName f
457 (base, _) = splitExt file
458 in return (f, dir, base)
459 _ -> onlyOne "output file"
461 let cProgName = outDir++outBase++"_hsc_make.c"
462 oProgName = outDir++outBase++"_hsc_make.o"
463 progName = outDir++outBase++"_hsc_make" ++ progNameSuffix
464 outHFile = outBase++"_hsc.h"
465 outHName = outDir++outHFile
466 outCName = outDir++outBase++"_hsc.c"
469 | null outDir = '.':pathSep:progName
470 | otherwise = progName
472 let specials = [(pos, key, arg) | Special pos key arg <- toks]
474 let needsC = any (\(_, key, _) -> key == "def") specials
477 let includeGuard = map fixChar outHName
479 fixChar c | isAlphaNum c = toUpper c
482 compiler <- case [c | Compiler c <- flags] of
485 _ -> onlyOne "compiler"
487 linker <- case [l | Linker l <- flags] of
490 _ -> onlyOne "linker"
492 writeFile cProgName $
493 concatMap outFlagHeaderCProg flags++
494 concatMap outHeaderCProg specials++
495 "\nint main (void)\n{\n"++
496 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
497 outHsLine (SourcePos name 0)++
498 concatMap outTokenHs toks++
501 unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess
503 compilerStatus <- system $
506 concat [" "++f | CompFlag f <- flags]++
509 case compilerStatus of
510 e@(ExitFailure _) -> exitWith e
514 linkerStatus <- system $
516 concat [" "++f | LinkFlag f <- flags]++
520 e@(ExitFailure _) -> exitWith e
524 progStatus <- system (execProgName++" >"++outName)
527 e@(ExitFailure _) -> exitWith e
530 when needsH $ writeFile outHName $
531 "#ifndef "++includeGuard++"\n\
532 \#define "++includeGuard++"\n\
534 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
537 \#include <HsFFI.h>\n\
540 \#define HsChar int\n\
542 concatMap outFlagH flags++
543 concatMap outTokenH specials++
546 when needsC $ writeFile outCName $
547 "#include \""++outHFile++"\"\n"++
548 concatMap outTokenC specials
549 -- NB. outHFile not outHName; works better when processed
550 -- by gcc or mkdependC.
552 onlyOne :: String -> IO a
554 putStrLn ("Only one "++what++" may be specified")
557 outFlagHeaderCProg :: Flag -> String
558 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
559 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
560 outFlagHeaderCProg (Define n Nothing) = "#define "++n++"\n"
561 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
562 outFlagHeaderCProg _ = ""
564 outHeaderCProg :: (SourcePos, String, String) -> String
565 outHeaderCProg (pos, key, arg) = case key of
566 "include" -> outCLine pos++"#include "++arg++"\n"
567 "define" -> outCLine pos++"#define "++arg++"\n"
568 "undef" -> outCLine pos++"#undef "++arg++"\n"
570 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
571 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
573 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
574 "let" -> case break (== '=') arg of
576 (header, _:body) -> case break isSpace header of
579 "#define hsc_"++name++"("++dropWhile isSpace args++") \
580 \printf ("++joinLines body++");\n"
583 joinLines = concat . intersperse " \\\n" . lines
585 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
586 outHeaderHs flags inH toks =
588 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
589 \ printf (\"{-# OPTIONS -optc-D" ++
590 "__GLASGOW_HASKELL__=%d #-}\\n\", \
591 \__GLASGOW_HASKELL__);\n\
594 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
595 Just f -> outOption ("-#include \""++f++"\"")
597 outFlag (Include f) = outOption ("-#include "++f)
598 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
599 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
601 outSpecial (pos, key, arg) = case key of
602 "include" -> outOption ("-#include "++arg)
603 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
605 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
607 goodForOptD arg = case arg of
609 c:_ | isSpace c -> True
612 toOptD arg = case break isSpace arg of
614 (name, _:value) -> name++'=':dropWhile isSpace value
615 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
616 showCString s++"\");\n"
618 outTokenHs :: Token -> String
619 outTokenHs (Text pos text) =
620 case break (== '\n') text of
621 (all, []) -> outText all
623 outText (first++"\n")++
627 outText s = " fputs (\""++showCString s++"\", stdout);\n"
628 outTokenHs (Special pos key arg) =
634 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
636 "enum" -> outCLine pos++outEnum arg
637 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
639 outEnum :: String -> String
641 case break (== ',') arg of
643 (t, _:afterT) -> case break (== ',') afterT of
646 enums (_:s) = case break (== ',') s of
648 this = case break (== '=') $ dropWhile isSpace enum of
650 " hsc_enum ("++t++", "++f++", \
651 \hsc_haskellize (\""++name++"\"), "++
654 " hsc_enum ("++t++", "++f++", \
655 \printf (\"%s\", \""++hsName++"\"), "++
660 outFlagH :: Flag -> String
661 outFlagH (Include f) = "#include "++f++"\n"
662 outFlagH (Define n Nothing) = "#define "++n++"\n"
663 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
666 outTokenH :: (SourcePos, String, String) -> String
667 outTokenH (pos, key, arg) =
669 "include" -> outCLine pos++"#include "++arg++"\n"
670 "define" -> outCLine pos++"#define " ++arg++"\n"
671 "undef" -> outCLine pos++"#undef " ++arg++"\n"
672 "def" -> outCLine pos++case arg of
673 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
674 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
675 'i':'n':'l':'i':'n':'e':' ':_ ->
680 _ -> "extern "++header++";\n"
681 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
682 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
685 outTokenC :: (SourcePos, String, String) -> String
686 outTokenC (pos, key, arg) =
689 's':'t':'r':'u':'c':'t':' ':_ -> ""
690 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
691 'i':'n':'l':'i':'n':'e':' ':arg' ->
692 case span (\c -> c /= '{' && c /= '=') arg' of
699 "\n#ifndef __GNUC__\n\
704 _ -> outCLine pos++arg++"\n"
705 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
708 conditional :: String -> Bool
709 conditional "if" = True
710 conditional "ifdef" = True
711 conditional "ifndef" = True
712 conditional "elif" = True
713 conditional "else" = True
714 conditional "endif" = True
715 conditional "error" = True
716 conditional "warning" = True
717 conditional _ = False
719 outCLine :: SourcePos -> String
720 outCLine (SourcePos name line) =
721 "# "++show line++" \""++showCString (snd (splitName name))++"\"\n"
723 outHsLine :: SourcePos -> String
724 outHsLine (SourcePos name line) =
725 " hsc_line ("++show (line + 1)++", \""++
726 showCString (snd (splitName name))++"\");\n"
728 showCString :: String -> String
729 showCString = concatMap showCChar
731 showCChar '\"' = "\\\""
732 showCChar '\'' = "\\\'"
733 showCChar '?' = "\\?"
734 showCChar '\\' = "\\\\"
735 showCChar c | c >= ' ' && c <= '~' = [c]
736 showCChar '\a' = "\\a"
737 showCChar '\b' = "\\b"
738 showCChar '\f' = "\\f"
739 showCChar '\n' = "\\n\"\n \""
740 showCChar '\r' = "\\r"
741 showCChar '\t' = "\\t"
742 showCChar '\v' = "\\v"
744 intToDigit (ord c `quot` 64),
745 intToDigit (ord c `quot` 8 `mod` 8),
746 intToDigit (ord c `mod` 8)]