1 ------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.33 2001/09/12 11:16:05 rrt 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)
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 #ifdef mingw32_TARGET_OS
74 h <- getModuleHandle Nothing
75 n <- getModuleFileName h
76 let tempName = reverse (drop (length "\\bin\\hsc2hs.exe") (reverse n)) ++ "\\template-hsc.h"
78 let (flags, files, errs) = getOpt Permute options args
79 let fflags = if [t | Template t <- flags] /= [] then flags else (Template tempName) : flags
80 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 = do
99 Parser p -> case p (SourcePos name 1) s of
100 Success _ _ _ toks -> output flags name toks
101 Failure (SourcePos name' line) msg -> do
102 putStrLn (name'++":"++show line++": "++msg)
105 ------------------------------------------------------------------------
106 -- A deterministic parser which remembers the text which has been parsed.
108 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
110 data ParseResult a = Success !SourcePos String String a
111 | Failure !SourcePos String
113 data SourcePos = SourcePos String !Int
115 updatePos :: SourcePos -> Char -> SourcePos
116 updatePos pos@(SourcePos name line) ch = case ch of
117 '\n' -> SourcePos name (line + 1)
120 instance Monad Parser where
121 return a = Parser $ \pos s -> Success pos [] s a
123 Parser $ \pos s -> case m pos s of
124 Success pos' out1 s' a -> case k a of
125 Parser k' -> case k' pos' s' of
126 Success pos'' out2 imp'' b ->
127 Success pos'' (out1++out2) imp'' b
128 Failure pos'' msg -> Failure pos'' msg
129 Failure pos' msg -> Failure pos' msg
130 fail msg = Parser $ \pos _ -> Failure pos msg
132 instance MonadPlus Parser where
134 Parser m `mplus` Parser n =
135 Parser $ \pos s -> case m pos s of
136 success@(Success _ _ _ _) -> success
137 Failure _ _ -> n pos s
139 getPos :: Parser SourcePos
140 getPos = Parser $ \pos s -> Success pos [] s pos
142 setPos :: SourcePos -> Parser ()
143 setPos pos = Parser $ \_ s -> Success pos [] s ()
145 message :: Parser a -> String -> Parser a
146 Parser m `message` msg =
147 Parser $ \pos s -> case m pos s of
148 success@(Success _ _ _ _) -> success
149 Failure pos' _ -> Failure pos' msg
151 catchOutput_ :: Parser a -> Parser String
152 catchOutput_ (Parser m) =
153 Parser $ \pos s -> case m pos s of
154 Success pos' out s' _ -> Success pos' [] s' out
155 Failure pos' msg -> Failure pos' msg
157 fakeOutput :: Parser a -> String -> Parser a
158 Parser m `fakeOutput` out =
159 Parser $ \pos s -> case m pos s of
160 Success pos' _ s' a -> Success pos' out s' a
161 Failure pos' msg -> Failure pos' msg
163 lookAhead :: Parser String
164 lookAhead = Parser $ \pos s -> Success pos [] s s
166 satisfy :: (Char -> Bool) -> Parser Char
168 Parser $ \pos s -> case s of
169 c:cs | p c -> Success (updatePos pos c) [c] cs c
170 _ -> Failure pos "Bad character"
172 char_ :: Char -> Parser ()
174 satisfy (== c) `message` (show c++" expected")
177 anyChar_ :: Parser ()
179 satisfy (const True) `message` "Unexpected end of file"
182 any2Chars_ :: Parser ()
183 any2Chars_ = anyChar_ >> anyChar_
185 many :: Parser a -> Parser [a]
186 many p = many1 p `mplus` return []
188 many1 :: Parser a -> Parser [a]
189 many1 p = liftM2 (:) p (many p)
191 many_ :: Parser a -> Parser ()
192 many_ p = many1_ p `mplus` return ()
194 many1_ :: Parser a -> Parser ()
195 many1_ p = p >> many_ p
197 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
198 manySatisfy = many . satisfy
199 manySatisfy1 = many1 . satisfy
201 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
202 manySatisfy_ = many_ . satisfy
203 manySatisfy1_ = many1_ . satisfy
205 ------------------------------------------------------------------------
206 -- Parser of hsc syntax.
209 = Text SourcePos String
210 | Special SourcePos String String
212 parser :: Parser [Token]
215 t <- catchOutput_ text
219 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
220 return (if null t then rest else Text pos t : rest)
227 c:_ | isAlpha c || c == '_' -> do
229 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
231 c:_ | isHsSymbol c -> do
232 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
235 '-':'-':symb' | all (== '-') symb' -> do
236 return () `fakeOutput` symb
237 manySatisfy_ (/= '\n')
240 return () `fakeOutput` unescapeHashes symb
242 '\"':_ -> do anyChar_; hsString '\"'; text
243 '\'':_ -> do anyChar_; hsString '\''; text
244 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
245 _:_ -> do anyChar_; text
247 hsString :: Char -> Parser ()
252 c:_ | c == quote -> anyChar_
257 char_ '\\' `mplus` return ()
259 | otherwise -> do any2Chars_; hsString quote
260 _:_ -> do anyChar_; hsString quote
262 hsComment :: Parser ()
267 '-':'}':_ -> any2Chars_
268 '{':'-':_ -> do any2Chars_; hsComment; hsComment
269 _:_ -> do anyChar_; hsComment
271 linePragma :: Parser ()
275 satisfy (\c -> c == 'L' || c == 'l')
276 satisfy (\c -> c == 'I' || c == 'i')
277 satisfy (\c -> c == 'N' || c == 'n')
278 satisfy (\c -> c == 'E' || c == 'e')
279 manySatisfy1_ isSpace
280 line <- liftM read $ manySatisfy1 isDigit
281 manySatisfy1_ isSpace
283 name <- manySatisfy (/= '\"')
289 setPos (SourcePos name (line - 1))
291 isHsSymbol :: Char -> Bool
292 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
293 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
294 isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True
295 isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True
296 isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True
297 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
298 isHsSymbol '~' = True
301 unescapeHashes :: String -> String
302 unescapeHashes [] = []
303 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
304 unescapeHashes (c:s) = c : unescapeHashes s
306 lookAheadC :: Parser String
307 lookAheadC = liftM joinLines lookAhead
310 joinLines ('\\':'\n':s) = joinLines s
311 joinLines (c:s) = c : joinLines s
313 satisfyC :: (Char -> Bool) -> Parser Char
317 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
320 charC_ :: Char -> Parser ()
322 satisfyC (== c) `message` (show c++" expected")
325 anyCharC_ :: Parser ()
327 satisfyC (const True) `message` "Unexpected end of file"
330 any2CharsC_ :: Parser ()
331 any2CharsC_ = anyCharC_ >> anyCharC_
333 manySatisfyC :: (Char -> Bool) -> Parser String
334 manySatisfyC = many . satisfyC
336 manySatisfyC_ :: (Char -> Bool) -> Parser ()
337 manySatisfyC_ = many_ . satisfyC
339 special :: Parser Token
341 manySatisfyC_ (\c -> isSpace c && c /= '\n')
346 manySatisfyC_ isSpace
347 sp <- keyArg (== '\n')
350 _ -> keyArg (const False)
352 keyArg :: (Char -> Bool) -> Parser Token
355 key <- keyword `message` "hsc keyword or '{' expected"
356 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
357 arg <- catchOutput_ (argument eol)
358 return (Special pos key arg)
360 keyword :: Parser String
362 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
363 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
366 argument :: (Char -> Bool) -> Parser ()
371 c:_ | eol c -> do anyCharC_; argument eol
373 '\"':_ -> do anyCharC_; cString '\"'; argument eol
374 '\'':_ -> do anyCharC_; cString '\''; argument eol
375 '(':_ -> do anyCharC_; nested ')'; argument eol
377 '/':'*':_ -> do any2CharsC_; cComment; argument eol
379 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
380 '[':_ -> do anyCharC_; nested ']'; argument eol
382 '{':_ -> do anyCharC_; nested '}'; argument eol
384 _:_ -> do anyCharC_; argument eol
386 nested :: Char -> Parser ()
387 nested c = do argument (== '\n'); charC_ c
389 cComment :: Parser ()
394 '*':'/':_ -> do any2CharsC_
395 _:_ -> do anyCharC_; cComment
397 cString :: Char -> Parser ()
402 c:_ | c == quote -> anyCharC_
403 '\\':_:_ -> do any2CharsC_; cString quote
404 _:_ -> do anyCharC_; cString quote
406 ------------------------------------------------------------------------
407 -- Write the output files.
409 splitName :: String -> (String, String)
411 case break (== '/') name of
412 (file, []) -> ([], file)
413 (dir, sep:rest) -> (dir++sep:restDir, restFile)
415 (restDir, restFile) = splitName rest
417 splitExt :: String -> (String, String)
419 case break (== '.') name of
420 (base, []) -> (base, [])
421 (base, sepRest@(sep:rest))
422 | null restExt -> (base, sepRest)
423 | otherwise -> (base++sep:restBase, restExt)
425 (restBase, restExt) = splitExt rest
427 output :: [Flag] -> String -> [Token] -> IO ()
428 output flags name toks = do
430 (outName, outDir, outBase) <- case [f | Output f <- flags] of
433 last ext == 'c' -> return (dir++base++init ext, dir, base)
434 | ext == ".hs" -> return (dir++base++"_out.hs", dir, base)
435 | otherwise -> return (dir++base++".hs", dir, base)
437 (dir, file) = splitName name
438 (base, ext) = splitExt file
440 (dir, file) = splitName f
441 (base, _) = splitExt file
442 in return (f, dir, base)
443 _ -> onlyOne "output file"
445 let cProgName = outDir++outBase++"_hsc_make.c"
446 oProgName = outDir++outBase++"_hsc_make.o"
447 progName = outDir++outBase++"_hsc_make" ++ progNameSuffix
448 outHName = outDir++outBase++"_hsc.h"
449 outCName = outDir++outBase++"_hsc.c"
452 | null outDir = "./"++progName
453 | otherwise = progName
455 let specials = [(pos, key, arg) | Special pos key arg <- toks]
457 let needsC = any (\(_, key, _) -> key == "def") specials
460 let includeGuard = map fixChar outHName
462 fixChar c | isAlphaNum c = toUpper c
465 compiler <- case [c | Compiler c <- flags] of
468 _ -> onlyOne "compiler"
470 linker <- case [l | Linker l <- flags] of
471 [] -> return defaultCompiler
473 _ -> onlyOne "linker"
475 writeFile cProgName $
476 concatMap outFlagHeaderCProg flags++
477 concatMap outHeaderCProg specials++
478 "\nint main (void)\n{\n"++
479 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
480 outHsLine (SourcePos name 0)++
481 concatMap outTokenHs toks++
484 unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess
486 compilerStatus <- system $
489 concat [" "++f | CompFlag f <- flags]++
492 case compilerStatus of
493 e@(ExitFailure _) -> exitWith e
497 linkerStatus <- system $
499 concat [" "++f | LinkFlag f <- flags]++
503 e@(ExitFailure _) -> exitWith e
507 system (execProgName++" >"++outName)
510 when needsH $ writeFile outHName $
511 "#ifndef "++includeGuard++"\n\
512 \#define "++includeGuard++"\n\
514 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
517 \#include <HsFFI.h>\n\
520 \#define HsChar int\n\
522 concatMap outFlagH flags++
523 concatMap outTokenH specials++
526 when needsC $ writeFile outCName $
527 "#include \""++outHName++"\"\n"++
528 concatMap outTokenC specials
530 onlyOne :: String -> IO a
532 putStrLn ("Only one "++what++" may be specified")
535 outFlagHeaderCProg :: Flag -> String
536 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
537 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
538 outFlagHeaderCProg (Define n Nothing) = "#define "++n++"\n"
539 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
540 outFlagHeaderCProg _ = ""
542 outHeaderCProg :: (SourcePos, String, String) -> String
543 outHeaderCProg (pos, key, arg) = case key of
544 "include" -> outCLine pos++"#include "++arg++"\n"
545 "define" -> outCLine pos++"#define "++arg++"\n"
546 "undef" -> outCLine pos++"#undef "++arg++"\n"
548 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
549 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
551 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
552 "let" -> case break (== '=') arg of
554 (header, _:body) -> case break isSpace header of
557 "#define hsc_"++name++"("++dropWhile isSpace args++") \
558 \printf ("++joinLines body++");\n"
561 joinLines = concat . intersperse " \\\n" . lines
563 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
564 outHeaderHs flags inH toks =
566 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
567 \ printf (\"{-# OPTIONS -optc-D" ++
568 "__GLASGOW_HASKELL__=%d #-}\\n\", \
569 \__GLASGOW_HASKELL__);\n\
572 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
573 Just f -> outOption ("-#include \""++f++"\"")
575 outFlag (Include f) = outOption ("-#include "++f)
576 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
577 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
579 outSpecial (pos, key, arg) = case key of
580 "include" -> outOption ("-#include "++arg)
581 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
583 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
585 goodForOptD arg = case arg of
587 c:_ | isSpace c -> True
590 toOptD arg = case break isSpace arg of
592 (name, _:value) -> name++'=':dropWhile isSpace value
593 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
594 showCString s++"\");\n"
596 outTokenHs :: Token -> String
597 outTokenHs (Text pos text) =
598 case break (== '\n') text of
599 (all, []) -> outText all
601 outText (first++"\n")++
605 outText s = " fputs (\""++showCString s++"\", stdout);\n"
606 outTokenHs (Special pos key arg) =
612 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
614 "enum" -> outCLine pos++outEnum arg
615 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
617 outEnum :: String -> String
619 case break (== ',') arg of
621 (t, _:afterT) -> case break (== ',') afterT of
624 enums (_:s) = case break (== ',') s of
626 this = case break (== '=') $ dropWhile isSpace enum of
628 " hsc_enum ("++t++", "++f++", \
629 \hsc_haskellize (\""++name++"\"), "++
632 " hsc_enum ("++t++", "++f++", \
633 \printf (\"%s\", \""++hsName++"\"), "++
638 outFlagH :: Flag -> String
639 outFlagH (Include f) = "#include "++f++"\n"
640 outFlagH (Define n Nothing) = "#define "++n++"\n"
641 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
644 outTokenH :: (SourcePos, String, String) -> String
645 outTokenH (pos, key, arg) =
647 "include" -> outCLine pos++"#include "++arg++"\n"
648 "define" -> outCLine pos++"#define " ++arg++"\n"
649 "undef" -> outCLine pos++"#undef " ++arg++"\n"
650 "def" -> outCLine pos++case arg of
651 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
652 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
653 'i':'n':'l':'i':'n':'e':' ':_ ->
658 _ -> "extern "++header++";\n"
659 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
660 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
663 outTokenC :: (SourcePos, String, String) -> String
664 outTokenC (pos, key, arg) =
667 's':'t':'r':'u':'c':'t':' ':_ -> ""
668 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
669 'i':'n':'l':'i':'n':'e':' ':arg' ->
670 case span (\c -> c /= '{' && c /= '=') arg' of
677 "\n#ifndef __GNUC__\n\
682 _ -> outCLine pos++arg++"\n"
683 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
686 conditional :: String -> Bool
687 conditional "if" = True
688 conditional "ifdef" = True
689 conditional "ifndef" = True
690 conditional "elif" = True
691 conditional "else" = True
692 conditional "endif" = True
693 conditional "error" = True
694 conditional "warning" = True
695 conditional _ = False
697 outCLine :: SourcePos -> String
698 outCLine (SourcePos name line) =
699 "# "++show line++" \""++showCString (snd (splitName name))++"\"\n"
701 outHsLine :: SourcePos -> String
702 outHsLine (SourcePos name line) =
703 " hsc_line ("++show (line + 1)++", \""++
704 showCString (snd (splitName name))++"\");\n"
706 showCString :: String -> String
707 showCString = concatMap showCChar
709 showCChar '\"' = "\\\""
710 showCChar '\'' = "\\\'"
711 showCChar '?' = "\\?"
712 showCChar '\\' = "\\\\"
713 showCChar c | c >= ' ' && c <= '~' = [c]
714 showCChar '\a' = "\\a"
715 showCChar '\b' = "\\b"
716 showCChar '\f' = "\\f"
717 showCChar '\n' = "\\n\"\n \""
718 showCChar '\r' = "\\r"
719 showCChar '\t' = "\\t"
720 showCChar '\v' = "\\v"
722 intToDigit (ord c `quot` 64),
723 intToDigit (ord c `quot` 8 `mod` 8),
724 intToDigit (ord c `mod` 8)]