1 ------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.38 2002/04/18 12:15:56 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.
14 import System (getProgName, getArgs, ExitCode(..), exitWith, exitFailure, system)
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)
20 #include "../../includes/config.h"
22 #ifdef mingw32_TARGET_OS
27 version = "hsc2hs-0.65"
39 | Define String (Maybe String)
42 include :: String -> Flag
43 include s@('\"':_) = Include s
44 include s@('<' :_) = Include s
45 include s = Include ("\""++s++"\"")
47 define :: String -> Flag
48 define s = case break (== '=') s of
49 (name, []) -> Define name Nothing
50 (name, _:value) -> Define name (Just value)
52 options :: [OptDescr Flag]
54 Option "t" ["template"] (ReqArg Template "FILE") "template file",
55 Option "c" ["cc"] (ReqArg Compiler "PROG") "C compiler to use",
56 Option "l" ["ld"] (ReqArg Linker "PROG") "linker to use",
57 Option "C" ["cflag"] (ReqArg CompFlag "FLAG") "flag to pass to the C compiler",
58 Option "I" [] (ReqArg (CompFlag . ("-I"++))
59 "DIR") "passed to the C compiler",
60 Option "L" ["lflag"] (ReqArg LinkFlag "FLAG") "flag to pass to the linker",
61 Option "i" ["include"] (ReqArg include "FILE") "as if placed in the source",
62 Option "D" ["define"] (ReqArg define "NAME[=VALUE]") "as if placed in the source",
63 Option "o" ["output"] (ReqArg Output "FILE") "name of main output file",
64 Option "" ["help"] (NoArg Help) "display this help and exit",
65 Option "" ["version"] (NoArg Version) "output version information and exit",
66 Option "" ["no-compile"] (NoArg NoCompile) "stop after writing *_hsc_make.c"]
71 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]"
73 let opts@(flags, files, errs) = getOpt Permute options args
74 #ifdef mingw32_TARGET_OS
75 h <- getModuleHandle Nothing
76 n <- getModuleFileName h
77 let tempName = reverse (drop (length "\\bin\\hsc2hs.exe") (reverse n)) ++ "\\template-hsc.h"
78 let fflags = if [t | Template t <- flags] /= [] then flags else (Template tempName) : flags
79 let opts = (fflags, files, errs)
83 | any isHelp flags -> putStrLn (usageInfo header options)
84 | any isVersion flags -> putStrLn version
86 isHelp Help = True; isHelp _ = False
87 isVersion Version = True; isVersion _ = False
88 (_, [], []) -> putStrLn (prog++": No input files")
89 (flags, files, []) -> mapM_ (processFile flags) files
92 putStrLn (usageInfo header options)
95 processFile :: [Flag] -> String -> IO ()
96 processFile flags name
97 = do let file_name = dosifyPath name
98 s <- readFile file_name
100 Parser p -> case p (SourcePos file_name 1) s of
101 Success _ _ _ toks -> output flags file_name toks
102 Failure (SourcePos name' line) msg -> do
103 putStrLn (name'++":"++show line++": "++msg)
106 ------------------------------------------------------------------------
107 -- Convert paths foo/baz to foo\baz on Windows
109 #if defined(mingw32_TARGET_OS)
110 subst a b ls = map (\ x -> if x == a then b else x) ls
111 dosifyPath xs = subst '/' '\\' xs
116 ------------------------------------------------------------------------
117 -- A deterministic parser which remembers the text which has been parsed.
119 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
121 data ParseResult a = Success !SourcePos String String a
122 | Failure !SourcePos String
124 data SourcePos = SourcePos String !Int
126 updatePos :: SourcePos -> Char -> SourcePos
127 updatePos pos@(SourcePos name line) ch = case ch of
128 '\n' -> SourcePos name (line + 1)
131 instance Monad Parser where
132 return a = Parser $ \pos s -> Success pos [] s a
134 Parser $ \pos s -> case m pos s of
135 Success pos' out1 s' a -> case k a of
136 Parser k' -> case k' pos' s' of
137 Success pos'' out2 imp'' b ->
138 Success pos'' (out1++out2) imp'' b
139 Failure pos'' msg -> Failure pos'' msg
140 Failure pos' msg -> Failure pos' msg
141 fail msg = Parser $ \pos _ -> Failure pos msg
143 instance MonadPlus Parser where
145 Parser m `mplus` Parser n =
146 Parser $ \pos s -> case m pos s of
147 success@(Success _ _ _ _) -> success
148 Failure _ _ -> n pos s
150 getPos :: Parser SourcePos
151 getPos = Parser $ \pos s -> Success pos [] s pos
153 setPos :: SourcePos -> Parser ()
154 setPos pos = Parser $ \_ s -> Success pos [] s ()
156 message :: Parser a -> String -> Parser a
157 Parser m `message` msg =
158 Parser $ \pos s -> case m pos s of
159 success@(Success _ _ _ _) -> success
160 Failure pos' _ -> Failure pos' msg
162 catchOutput_ :: Parser a -> Parser String
163 catchOutput_ (Parser m) =
164 Parser $ \pos s -> case m pos s of
165 Success pos' out s' _ -> Success pos' [] s' out
166 Failure pos' msg -> Failure pos' msg
168 fakeOutput :: Parser a -> String -> Parser a
169 Parser m `fakeOutput` out =
170 Parser $ \pos s -> case m pos s of
171 Success pos' _ s' a -> Success pos' out s' a
172 Failure pos' msg -> Failure pos' msg
174 lookAhead :: Parser String
175 lookAhead = Parser $ \pos s -> Success pos [] s s
177 satisfy :: (Char -> Bool) -> Parser Char
179 Parser $ \pos s -> case s of
180 c:cs | p c -> Success (updatePos pos c) [c] cs c
181 _ -> Failure pos "Bad character"
183 char_ :: Char -> Parser ()
185 satisfy (== c) `message` (show c++" expected")
188 anyChar_ :: Parser ()
190 satisfy (const True) `message` "Unexpected end of file"
193 any2Chars_ :: Parser ()
194 any2Chars_ = anyChar_ >> anyChar_
196 many :: Parser a -> Parser [a]
197 many p = many1 p `mplus` return []
199 many1 :: Parser a -> Parser [a]
200 many1 p = liftM2 (:) p (many p)
202 many_ :: Parser a -> Parser ()
203 many_ p = many1_ p `mplus` return ()
205 many1_ :: Parser a -> Parser ()
206 many1_ p = p >> many_ p
208 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
209 manySatisfy = many . satisfy
210 manySatisfy1 = many1 . satisfy
212 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
213 manySatisfy_ = many_ . satisfy
214 manySatisfy1_ = many1_ . satisfy
216 ------------------------------------------------------------------------
217 -- Parser of hsc syntax.
220 = Text SourcePos String
221 | Special SourcePos String String
223 parser :: Parser [Token]
226 t <- catchOutput_ text
230 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
231 return (if null t then rest else Text pos t : rest)
238 c:_ | isAlpha c || c == '_' -> do
240 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
242 c:_ | isHsSymbol c -> do
243 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
246 '-':'-':symb' | all (== '-') symb' -> do
247 return () `fakeOutput` symb
248 manySatisfy_ (/= '\n')
251 return () `fakeOutput` unescapeHashes symb
253 '\"':_ -> do anyChar_; hsString '\"'; text
254 '\'':_ -> do anyChar_; hsString '\''; text
255 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
256 _:_ -> do anyChar_; text
258 hsString :: Char -> Parser ()
263 c:_ | c == quote -> anyChar_
268 char_ '\\' `mplus` return ()
270 | otherwise -> do any2Chars_; hsString quote
271 _:_ -> do anyChar_; hsString quote
273 hsComment :: Parser ()
278 '-':'}':_ -> any2Chars_
279 '{':'-':_ -> do any2Chars_; hsComment; hsComment
280 _:_ -> do anyChar_; hsComment
282 linePragma :: Parser ()
286 satisfy (\c -> c == 'L' || c == 'l')
287 satisfy (\c -> c == 'I' || c == 'i')
288 satisfy (\c -> c == 'N' || c == 'n')
289 satisfy (\c -> c == 'E' || c == 'e')
290 manySatisfy1_ isSpace
291 line <- liftM read $ manySatisfy1 isDigit
292 manySatisfy1_ isSpace
294 name <- manySatisfy (/= '\"')
300 setPos (SourcePos name (line - 1))
302 isHsSymbol :: Char -> Bool
303 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
304 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
305 isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True
306 isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True
307 isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True
308 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
309 isHsSymbol '~' = True
312 unescapeHashes :: String -> String
313 unescapeHashes [] = []
314 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
315 unescapeHashes (c:s) = c : unescapeHashes s
317 lookAheadC :: Parser String
318 lookAheadC = liftM joinLines lookAhead
321 joinLines ('\\':'\n':s) = joinLines s
322 joinLines (c:s) = c : joinLines s
324 satisfyC :: (Char -> Bool) -> Parser Char
328 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
331 charC_ :: Char -> Parser ()
333 satisfyC (== c) `message` (show c++" expected")
336 anyCharC_ :: Parser ()
338 satisfyC (const True) `message` "Unexpected end of file"
341 any2CharsC_ :: Parser ()
342 any2CharsC_ = anyCharC_ >> anyCharC_
344 manySatisfyC :: (Char -> Bool) -> Parser String
345 manySatisfyC = many . satisfyC
347 manySatisfyC_ :: (Char -> Bool) -> Parser ()
348 manySatisfyC_ = many_ . satisfyC
350 special :: Parser Token
352 manySatisfyC_ (\c -> isSpace c && c /= '\n')
357 manySatisfyC_ isSpace
358 sp <- keyArg (== '\n')
361 _ -> keyArg (const False)
363 keyArg :: (Char -> Bool) -> Parser Token
366 key <- keyword `message` "hsc keyword or '{' expected"
367 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
368 arg <- catchOutput_ (argument eol)
369 return (Special pos key arg)
371 keyword :: Parser String
373 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
374 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
377 argument :: (Char -> Bool) -> Parser ()
382 c:_ | eol c -> do anyCharC_; argument eol
384 '\"':_ -> do anyCharC_; cString '\"'; argument eol
385 '\'':_ -> do anyCharC_; cString '\''; argument eol
386 '(':_ -> do anyCharC_; nested ')'; argument eol
388 '/':'*':_ -> do any2CharsC_; cComment; argument eol
390 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
391 '[':_ -> do anyCharC_; nested ']'; argument eol
393 '{':_ -> do anyCharC_; nested '}'; argument eol
395 _:_ -> do anyCharC_; argument eol
397 nested :: Char -> Parser ()
398 nested c = do argument (== '\n'); charC_ c
400 cComment :: Parser ()
405 '*':'/':_ -> do any2CharsC_
406 _:_ -> do anyCharC_; cComment
408 cString :: Char -> Parser ()
413 c:_ | c == quote -> anyCharC_
414 '\\':_:_ -> do any2CharsC_; cString quote
415 _:_ -> do anyCharC_; cString quote
417 ------------------------------------------------------------------------
418 -- Write the output files.
420 splitName :: String -> (String, String)
422 case break (== '/') name of
423 (file, []) -> ([], file)
424 (dir, sep:rest) -> (dir++sep:restDir, restFile)
426 (restDir, restFile) = splitName rest
428 splitExt :: String -> (String, String)
430 case break (== '.') name of
431 (base, []) -> (base, [])
432 (base, sepRest@(sep:rest))
433 | null restExt -> (base, sepRest)
434 | otherwise -> (base++sep:restBase, restExt)
436 (restBase, restExt) = splitExt rest
438 output :: [Flag] -> String -> [Token] -> IO ()
439 output flags name toks = do
441 (outName, outDir, outBase) <- case [f | Output f <- flags] of
444 last ext == 'c' -> return (dir++base++init ext, dir, base)
445 | ext == ".hs" -> return (dir++base++"_out.hs", dir, base)
446 | otherwise -> return (dir++base++".hs", dir, base)
448 (dir, file) = splitName name
449 (base, ext) = splitExt file
451 (dir, file) = splitName f
452 (base, _) = splitExt file
453 in return (f, dir, base)
454 _ -> onlyOne "output file"
456 let cProgName = outDir++outBase++"_hsc_make.c"
457 oProgName = outDir++outBase++"_hsc_make.o"
458 progName = outDir++outBase++"_hsc_make" ++ progNameSuffix
459 outHFile = outBase++"_hsc.h"
460 outHName = outDir++outHFile
461 outCName = outDir++outBase++"_hsc.c"
464 | null outDir = '.':pathSep:progName
465 | otherwise = progName
467 let specials = [(pos, key, arg) | Special pos key arg <- toks]
469 let needsC = any (\(_, key, _) -> key == "def") specials
472 let includeGuard = map fixChar outHName
474 fixChar c | isAlphaNum c = toUpper c
477 compiler <- case [c | Compiler c <- flags] of
480 _ -> onlyOne "compiler"
482 linker <- case [l | Linker l <- flags] of
485 _ -> onlyOne "linker"
487 writeFile cProgName $
488 concatMap outFlagHeaderCProg flags++
489 concatMap outHeaderCProg specials++
490 "\nint main (void)\n{\n"++
491 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
492 outHsLine (SourcePos name 0)++
493 concatMap outTokenHs toks++
496 unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess
498 compilerStatus <- system $
501 concat [" "++f | CompFlag f <- flags]++
504 case compilerStatus of
505 e@(ExitFailure _) -> exitWith e
509 linkerStatus <- system $
511 concat [" "++f | LinkFlag f <- flags]++
515 e@(ExitFailure _) -> exitWith e
519 progStatus <- system (execProgName++" >"++outName)
522 e@(ExitFailure _) -> exitWith e
525 when needsH $ writeFile outHName $
526 "#ifndef "++includeGuard++"\n\
527 \#define "++includeGuard++"\n\
529 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
532 \#include <HsFFI.h>\n\
535 \#define HsChar int\n\
537 concatMap outFlagH flags++
538 concatMap outTokenH specials++
541 when needsC $ writeFile outCName $
542 "#include \""++outHFile++"\"\n"++
543 concatMap outTokenC specials
544 -- NB. outHFile not outHName; works better when processed
545 -- by gcc or mkdependC.
547 onlyOne :: String -> IO a
549 putStrLn ("Only one "++what++" may be specified")
552 outFlagHeaderCProg :: Flag -> String
553 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
554 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
555 outFlagHeaderCProg (Define n Nothing) = "#define "++n++"\n"
556 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
557 outFlagHeaderCProg _ = ""
559 outHeaderCProg :: (SourcePos, String, String) -> String
560 outHeaderCProg (pos, key, arg) = case key of
561 "include" -> outCLine pos++"#include "++arg++"\n"
562 "define" -> outCLine pos++"#define "++arg++"\n"
563 "undef" -> outCLine pos++"#undef "++arg++"\n"
565 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
566 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
568 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
569 "let" -> case break (== '=') arg of
571 (header, _:body) -> case break isSpace header of
574 "#define hsc_"++name++"("++dropWhile isSpace args++") \
575 \printf ("++joinLines body++");\n"
578 joinLines = concat . intersperse " \\\n" . lines
580 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
581 outHeaderHs flags inH toks =
583 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
584 \ printf (\"{-# OPTIONS -optc-D" ++
585 "__GLASGOW_HASKELL__=%d #-}\\n\", \
586 \__GLASGOW_HASKELL__);\n\
589 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
590 Just f -> outOption ("-#include \""++f++"\"")
592 outFlag (Include f) = outOption ("-#include "++f)
593 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
594 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
596 outSpecial (pos, key, arg) = case key of
597 "include" -> outOption ("-#include "++arg)
598 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
600 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
602 goodForOptD arg = case arg of
604 c:_ | isSpace c -> True
607 toOptD arg = case break isSpace arg of
609 (name, _:value) -> name++'=':dropWhile isSpace value
610 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
611 showCString s++"\");\n"
613 outTokenHs :: Token -> String
614 outTokenHs (Text pos text) =
615 case break (== '\n') text of
616 (all, []) -> outText all
618 outText (first++"\n")++
622 outText s = " fputs (\""++showCString s++"\", stdout);\n"
623 outTokenHs (Special pos key arg) =
629 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
631 "enum" -> outCLine pos++outEnum arg
632 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
634 outEnum :: String -> String
636 case break (== ',') arg of
638 (t, _:afterT) -> case break (== ',') afterT of
641 enums (_:s) = case break (== ',') s of
643 this = case break (== '=') $ dropWhile isSpace enum of
645 " hsc_enum ("++t++", "++f++", \
646 \hsc_haskellize (\""++name++"\"), "++
649 " hsc_enum ("++t++", "++f++", \
650 \printf (\"%s\", \""++hsName++"\"), "++
655 outFlagH :: Flag -> String
656 outFlagH (Include f) = "#include "++f++"\n"
657 outFlagH (Define n Nothing) = "#define "++n++"\n"
658 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
661 outTokenH :: (SourcePos, String, String) -> String
662 outTokenH (pos, key, arg) =
664 "include" -> outCLine pos++"#include "++arg++"\n"
665 "define" -> outCLine pos++"#define " ++arg++"\n"
666 "undef" -> outCLine pos++"#undef " ++arg++"\n"
667 "def" -> outCLine pos++case arg of
668 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
669 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
670 'i':'n':'l':'i':'n':'e':' ':_ ->
675 _ -> "extern "++header++";\n"
676 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
677 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
680 outTokenC :: (SourcePos, String, String) -> String
681 outTokenC (pos, key, arg) =
684 's':'t':'r':'u':'c':'t':' ':_ -> ""
685 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
686 'i':'n':'l':'i':'n':'e':' ':arg' ->
687 case span (\c -> c /= '{' && c /= '=') arg' of
694 "\n#ifndef __GNUC__\n\
699 _ -> outCLine pos++arg++"\n"
700 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
703 conditional :: String -> Bool
704 conditional "if" = True
705 conditional "ifdef" = True
706 conditional "ifndef" = True
707 conditional "elif" = True
708 conditional "else" = True
709 conditional "endif" = True
710 conditional "error" = True
711 conditional "warning" = True
712 conditional _ = False
714 outCLine :: SourcePos -> String
715 outCLine (SourcePos name line) =
716 "# "++show line++" \""++showCString (snd (splitName name))++"\"\n"
718 outHsLine :: SourcePos -> String
719 outHsLine (SourcePos name line) =
720 " hsc_line ("++show (line + 1)++", \""++
721 showCString (snd (splitName name))++"\");\n"
723 showCString :: String -> String
724 showCString = concatMap showCChar
726 showCChar '\"' = "\\\""
727 showCChar '\'' = "\\\'"
728 showCChar '?' = "\\?"
729 showCChar '\\' = "\\\\"
730 showCChar c | c >= ' ' && c <= '~' = [c]
731 showCChar '\a' = "\\a"
732 showCChar '\b' = "\\b"
733 showCChar '\f' = "\\f"
734 showCChar '\n' = "\\n\"\n \""
735 showCChar '\r' = "\\r"
736 showCChar '\t' = "\\t"
737 showCChar '\v' = "\\v"
739 intToDigit (ord c `quot` 64),
740 intToDigit (ord c `quot` 8 `mod` 8),
741 intToDigit (ord c `mod` 8)]