1 ------------------------------------------------------------------------
2 -- $Id: Main.hs,v 1.41 2002/10/27 10:38:33 mthomas 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
29 import Foreign.C.String (CString, peekCString)
30 import Foreign.C.Types
31 import Foreign.Ptr (nullPtr)
32 import Foreign.Marshal.Alloc (mallocBytes, free)
34 foreign import stdcall "GetModuleHandle" c_GetModuleHandle :: CString -> IO CUInt
35 foreign import stdcall "GetModuleFileName" c_GetModuleFilename :: CUInt -> CString -> CUInt -> IO CUInt
38 ourName = do h <- c_GetModuleHandle nullPtr
39 cstr <- mallocBytes cstr_len
40 rv <- c_GetModuleFilename h cstr (CUInt (fromIntegral cstr_len))
41 str <- peekCString cstr
48 version = "hsc2hs-0.65"
60 | Define String (Maybe String)
63 include :: String -> Flag
64 include s@('\"':_) = Include s
65 include s@('<' :_) = Include s
66 include s = Include ("\""++s++"\"")
68 define :: String -> Flag
69 define s = case break (== '=') s of
70 (name, []) -> Define name Nothing
71 (name, _:value) -> Define name (Just value)
73 options :: [OptDescr Flag]
75 Option "t" ["template"] (ReqArg Template "FILE") "template file",
76 Option "c" ["cc"] (ReqArg Compiler "PROG") "C compiler to use",
77 Option "l" ["ld"] (ReqArg Linker "PROG") "linker to use",
78 Option "C" ["cflag"] (ReqArg CompFlag "FLAG") "flag to pass to the C compiler",
79 Option "I" [] (ReqArg (CompFlag . ("-I"++))
80 "DIR") "passed to the C compiler",
81 Option "L" ["lflag"] (ReqArg LinkFlag "FLAG") "flag to pass to the linker",
82 Option "i" ["include"] (ReqArg include "FILE") "as if placed in the source",
83 Option "D" ["define"] (ReqArg define "NAME[=VALUE]") "as if placed in the source",
84 Option "o" ["output"] (ReqArg Output "FILE") "name of main output file",
85 Option "" ["help"] (NoArg Help) "display this help and exit",
86 Option "" ["version"] (NoArg Version) "output version information and exit",
87 Option "" ["no-compile"] (NoArg NoCompile) "stop after writing *_hsc_make.c"]
92 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]"
94 let opts@(flags, files, errs) = getOpt Permute options args
95 #ifdef mingw32_HOST_OS
97 let tempName = reverse (drop (length "\\bin\\hsc2hs.exe") (reverse n)) ++ "\\template-hsc.h"
98 let fflags = if [t | Template t <- flags] /= [] then flags else (Template tempName) : flags
99 let opts = (fflags, files, errs)
103 | any isHelp flags -> putStrLn (usageInfo header options)
104 | any isVersion flags -> putStrLn version
106 isHelp Help = True; isHelp _ = False
107 isVersion Version = True; isVersion _ = False
108 (_, [], []) -> putStrLn (prog++": No input files")
109 (flags, files, []) -> mapM_ (processFile flags) files
112 putStrLn (usageInfo header options)
115 processFile :: [Flag] -> String -> IO ()
116 processFile flags name
117 = do let file_name = dosifyPath name
118 s <- readFile file_name
120 Parser p -> case p (SourcePos file_name 1) s of
121 Success _ _ _ toks -> output flags file_name toks
122 Failure (SourcePos name' line) msg -> do
123 putStrLn (name'++":"++show line++": "++msg)
126 ------------------------------------------------------------------------
127 -- Convert paths foo/baz to foo\baz on Windows
129 #if defined(mingw32_HOST_OS)
130 subst a b ls = map (\ x -> if x == a then b else x) ls
131 dosifyPath xs = subst '/' '\\' xs
136 ------------------------------------------------------------------------
137 -- A deterministic parser which remembers the text which has been parsed.
139 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
141 data ParseResult a = Success !SourcePos String String a
142 | Failure !SourcePos String
144 data SourcePos = SourcePos String !Int
146 updatePos :: SourcePos -> Char -> SourcePos
147 updatePos pos@(SourcePos name line) ch = case ch of
148 '\n' -> SourcePos name (line + 1)
151 instance Monad Parser where
152 return a = Parser $ \pos s -> Success pos [] s a
154 Parser $ \pos s -> case m pos s of
155 Success pos' out1 s' a -> case k a of
156 Parser k' -> case k' pos' s' of
157 Success pos'' out2 imp'' b ->
158 Success pos'' (out1++out2) imp'' b
159 Failure pos'' msg -> Failure pos'' msg
160 Failure pos' msg -> Failure pos' msg
161 fail msg = Parser $ \pos _ -> Failure pos msg
163 instance MonadPlus Parser where
165 Parser m `mplus` Parser n =
166 Parser $ \pos s -> case m pos s of
167 success@(Success _ _ _ _) -> success
168 Failure _ _ -> n pos s
170 getPos :: Parser SourcePos
171 getPos = Parser $ \pos s -> Success pos [] s pos
173 setPos :: SourcePos -> Parser ()
174 setPos pos = Parser $ \_ s -> Success pos [] s ()
176 message :: Parser a -> String -> Parser a
177 Parser m `message` msg =
178 Parser $ \pos s -> case m pos s of
179 success@(Success _ _ _ _) -> success
180 Failure pos' _ -> Failure pos' msg
182 catchOutput_ :: Parser a -> Parser String
183 catchOutput_ (Parser m) =
184 Parser $ \pos s -> case m pos s of
185 Success pos' out s' _ -> Success pos' [] s' out
186 Failure pos' msg -> Failure pos' msg
188 fakeOutput :: Parser a -> String -> Parser a
189 Parser m `fakeOutput` out =
190 Parser $ \pos s -> case m pos s of
191 Success pos' _ s' a -> Success pos' out s' a
192 Failure pos' msg -> Failure pos' msg
194 lookAhead :: Parser String
195 lookAhead = Parser $ \pos s -> Success pos [] s s
197 satisfy :: (Char -> Bool) -> Parser Char
199 Parser $ \pos s -> case s of
200 c:cs | p c -> Success (updatePos pos c) [c] cs c
201 _ -> Failure pos "Bad character"
203 char_ :: Char -> Parser ()
205 satisfy (== c) `message` (show c++" expected")
208 anyChar_ :: Parser ()
210 satisfy (const True) `message` "Unexpected end of file"
213 any2Chars_ :: Parser ()
214 any2Chars_ = anyChar_ >> anyChar_
216 many :: Parser a -> Parser [a]
217 many p = many1 p `mplus` return []
219 many1 :: Parser a -> Parser [a]
220 many1 p = liftM2 (:) p (many p)
222 many_ :: Parser a -> Parser ()
223 many_ p = many1_ p `mplus` return ()
225 many1_ :: Parser a -> Parser ()
226 many1_ p = p >> many_ p
228 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
229 manySatisfy = many . satisfy
230 manySatisfy1 = many1 . satisfy
232 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
233 manySatisfy_ = many_ . satisfy
234 manySatisfy1_ = many1_ . satisfy
236 ------------------------------------------------------------------------
237 -- Parser of hsc syntax.
240 = Text SourcePos String
241 | Special SourcePos String String
243 parser :: Parser [Token]
246 t <- catchOutput_ text
250 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
251 return (if null t then rest else Text pos t : rest)
258 c:_ | isAlpha c || c == '_' -> do
260 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
262 c:_ | isHsSymbol c -> do
263 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
266 '-':'-':symb' | all (== '-') symb' -> do
267 return () `fakeOutput` symb
268 manySatisfy_ (/= '\n')
271 return () `fakeOutput` unescapeHashes symb
273 '\"':_ -> do anyChar_; hsString '\"'; text
274 '\'':_ -> do anyChar_; hsString '\''; text
275 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
276 _:_ -> do anyChar_; text
278 hsString :: Char -> Parser ()
283 c:_ | c == quote -> anyChar_
288 char_ '\\' `mplus` return ()
290 | otherwise -> do any2Chars_; hsString quote
291 _:_ -> do anyChar_; hsString quote
293 hsComment :: Parser ()
298 '-':'}':_ -> any2Chars_
299 '{':'-':_ -> do any2Chars_; hsComment; hsComment
300 _:_ -> do anyChar_; hsComment
302 linePragma :: Parser ()
306 satisfy (\c -> c == 'L' || c == 'l')
307 satisfy (\c -> c == 'I' || c == 'i')
308 satisfy (\c -> c == 'N' || c == 'n')
309 satisfy (\c -> c == 'E' || c == 'e')
310 manySatisfy1_ isSpace
311 line <- liftM read $ manySatisfy1 isDigit
312 manySatisfy1_ isSpace
314 name <- manySatisfy (/= '\"')
320 setPos (SourcePos name (line - 1))
322 isHsSymbol :: Char -> Bool
323 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
324 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
325 isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True
326 isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True
327 isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True
328 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
329 isHsSymbol '~' = True
332 unescapeHashes :: String -> String
333 unescapeHashes [] = []
334 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
335 unescapeHashes (c:s) = c : unescapeHashes s
337 lookAheadC :: Parser String
338 lookAheadC = liftM joinLines lookAhead
341 joinLines ('\\':'\n':s) = joinLines s
342 joinLines (c:s) = c : joinLines s
344 satisfyC :: (Char -> Bool) -> Parser Char
348 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
351 charC_ :: Char -> Parser ()
353 satisfyC (== c) `message` (show c++" expected")
356 anyCharC_ :: Parser ()
358 satisfyC (const True) `message` "Unexpected end of file"
361 any2CharsC_ :: Parser ()
362 any2CharsC_ = anyCharC_ >> anyCharC_
364 manySatisfyC :: (Char -> Bool) -> Parser String
365 manySatisfyC = many . satisfyC
367 manySatisfyC_ :: (Char -> Bool) -> Parser ()
368 manySatisfyC_ = many_ . satisfyC
370 special :: Parser Token
372 manySatisfyC_ (\c -> isSpace c && c /= '\n')
377 manySatisfyC_ isSpace
378 sp <- keyArg (== '\n')
381 _ -> keyArg (const False)
383 keyArg :: (Char -> Bool) -> Parser Token
386 key <- keyword `message` "hsc keyword or '{' expected"
387 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
388 arg <- catchOutput_ (argument eol)
389 return (Special pos key arg)
391 keyword :: Parser String
393 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
394 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
397 argument :: (Char -> Bool) -> Parser ()
402 c:_ | eol c -> do anyCharC_; argument eol
404 '\"':_ -> do anyCharC_; cString '\"'; argument eol
405 '\'':_ -> do anyCharC_; cString '\''; argument eol
406 '(':_ -> do anyCharC_; nested ')'; argument eol
408 '/':'*':_ -> do any2CharsC_; cComment; argument eol
410 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
411 '[':_ -> do anyCharC_; nested ']'; argument eol
413 '{':_ -> do anyCharC_; nested '}'; argument eol
415 _:_ -> do anyCharC_; argument eol
417 nested :: Char -> Parser ()
418 nested c = do argument (== '\n'); charC_ c
420 cComment :: Parser ()
425 '*':'/':_ -> do any2CharsC_
426 _:_ -> do anyCharC_; cComment
428 cString :: Char -> Parser ()
433 c:_ | c == quote -> anyCharC_
434 '\\':_:_ -> do any2CharsC_; cString quote
435 _:_ -> do anyCharC_; cString quote
437 ------------------------------------------------------------------------
438 -- Write the output files.
440 splitName :: String -> (String, String)
442 case break (== '/') name of
443 (file, []) -> ([], file)
444 (dir, sep:rest) -> (dir++sep:restDir, restFile)
446 (restDir, restFile) = splitName rest
448 splitExt :: String -> (String, String)
450 case break (== '.') name of
451 (base, []) -> (base, [])
452 (base, sepRest@(sep:rest))
453 | null restExt -> (base, sepRest)
454 | otherwise -> (base++sep:restBase, restExt)
456 (restBase, restExt) = splitExt rest
458 output :: [Flag] -> String -> [Token] -> IO ()
459 output flags name toks = do
461 (outName, outDir, outBase) <- case [f | Output f <- flags] of
464 last ext == 'c' -> return (dir++base++init ext, dir, base)
465 | ext == ".hs" -> return (dir++base++"_out.hs", dir, base)
466 | otherwise -> return (dir++base++".hs", dir, base)
468 (dir, file) = splitName name
469 (base, ext) = splitExt file
471 (dir, file) = splitName f
472 (base, _) = splitExt file
473 in return (f, dir, base)
474 _ -> onlyOne "output file"
476 let cProgName = outDir++outBase++"_hsc_make.c"
477 oProgName = outDir++outBase++"_hsc_make.o"
478 progName = outDir++outBase++"_hsc_make" ++ progNameSuffix
479 outHFile = outBase++"_hsc.h"
480 outHName = outDir++outHFile
481 outCName = outDir++outBase++"_hsc.c"
484 | null outDir = '.':pathSep:progName
485 | otherwise = progName
487 let specials = [(pos, key, arg) | Special pos key arg <- toks]
489 let needsC = any (\(_, key, _) -> key == "def") specials
492 let includeGuard = map fixChar outHName
494 fixChar c | isAlphaNum c = toUpper c
497 compiler <- case [c | Compiler c <- flags] of
500 _ -> onlyOne "compiler"
502 linker <- case [l | Linker l <- flags] of
505 _ -> onlyOne "linker"
507 writeFile cProgName $
508 concatMap outFlagHeaderCProg flags++
509 concatMap outHeaderCProg specials++
510 "\nint main (void)\n{\n"++
511 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
512 outHsLine (SourcePos name 0)++
513 concatMap outTokenHs toks++
516 unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess
518 compilerStatus <- system $
521 concat [" "++f | CompFlag f <- flags]++
524 case compilerStatus of
525 e@(ExitFailure _) -> exitWith e
529 linkerStatus <- system $
531 concat [" "++f | LinkFlag f <- flags]++
535 e@(ExitFailure _) -> exitWith e
539 progStatus <- system (execProgName++" >"++outName)
542 e@(ExitFailure _) -> exitWith e
545 when needsH $ writeFile outHName $
546 "#ifndef "++includeGuard++"\n\
547 \#define "++includeGuard++"\n\
549 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
552 \#include <HsFFI.h>\n\
555 \#define HsChar int\n\
557 concatMap outFlagH flags++
558 concatMap outTokenH specials++
561 when needsC $ writeFile outCName $
562 "#include \""++outHFile++"\"\n"++
563 concatMap outTokenC specials
564 -- NB. outHFile not outHName; works better when processed
565 -- by gcc or mkdependC.
567 onlyOne :: String -> IO a
569 putStrLn ("Only one "++what++" may be specified")
572 outFlagHeaderCProg :: Flag -> String
573 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
574 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
575 outFlagHeaderCProg (Define n Nothing) = "#define "++n++"\n"
576 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
577 outFlagHeaderCProg _ = ""
579 outHeaderCProg :: (SourcePos, String, String) -> String
580 outHeaderCProg (pos, key, arg) = case key of
581 "include" -> outCLine pos++"#include "++arg++"\n"
582 "define" -> outCLine pos++"#define "++arg++"\n"
583 "undef" -> outCLine pos++"#undef "++arg++"\n"
585 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
586 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
588 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
589 "let" -> case break (== '=') arg of
591 (header, _:body) -> case break isSpace header of
594 "#define hsc_"++name++"("++dropWhile isSpace args++") \
595 \printf ("++joinLines body++");\n"
598 joinLines = concat . intersperse " \\\n" . lines
600 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
601 outHeaderHs flags inH toks =
603 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
604 \ printf (\"{-# OPTIONS -optc-D" ++
605 "__GLASGOW_HASKELL__=%d #-}\\n\", \
606 \__GLASGOW_HASKELL__);\n\
609 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
610 Just f -> outOption ("-#include \""++f++"\"")
612 outFlag (Include f) = outOption ("-#include "++f)
613 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
614 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
616 outSpecial (pos, key, arg) = case key of
617 "include" -> outOption ("-#include "++arg)
618 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
620 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
622 goodForOptD arg = case arg of
624 c:_ | isSpace c -> True
627 toOptD arg = case break isSpace arg of
629 (name, _:value) -> name++'=':dropWhile isSpace value
630 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
631 showCString s++"\");\n"
633 outTokenHs :: Token -> String
634 outTokenHs (Text pos text) =
635 case break (== '\n') text of
636 (all, []) -> outText all
638 outText (first++"\n")++
642 outText s = " fputs (\""++showCString s++"\", stdout);\n"
643 outTokenHs (Special pos key arg) =
649 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
651 "enum" -> outCLine pos++outEnum arg
652 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
654 outEnum :: String -> String
656 case break (== ',') arg of
658 (t, _:afterT) -> case break (== ',') afterT of
661 enums (_:s) = case break (== ',') s of
663 this = case break (== '=') $ dropWhile isSpace enum of
665 " hsc_enum ("++t++", "++f++", \
666 \hsc_haskellize (\""++name++"\"), "++
669 " hsc_enum ("++t++", "++f++", \
670 \printf (\"%s\", \""++hsName++"\"), "++
675 outFlagH :: Flag -> String
676 outFlagH (Include f) = "#include "++f++"\n"
677 outFlagH (Define n Nothing) = "#define "++n++"\n"
678 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
681 outTokenH :: (SourcePos, String, String) -> String
682 outTokenH (pos, key, arg) =
684 "include" -> outCLine pos++"#include "++arg++"\n"
685 "define" -> outCLine pos++"#define " ++arg++"\n"
686 "undef" -> outCLine pos++"#undef " ++arg++"\n"
687 "def" -> outCLine pos++case arg of
688 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
689 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
690 'i':'n':'l':'i':'n':'e':' ':_ ->
695 _ -> "extern "++header++";\n"
696 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
697 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
700 outTokenC :: (SourcePos, String, String) -> String
701 outTokenC (pos, key, arg) =
704 's':'t':'r':'u':'c':'t':' ':_ -> ""
705 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
706 'i':'n':'l':'i':'n':'e':' ':arg' ->
707 case span (\c -> c /= '{' && c /= '=') arg' of
714 "\n#ifndef __GNUC__\n\
719 _ -> outCLine pos++arg++"\n"
720 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
723 conditional :: String -> Bool
724 conditional "if" = True
725 conditional "ifdef" = True
726 conditional "ifndef" = True
727 conditional "elif" = True
728 conditional "else" = True
729 conditional "endif" = True
730 conditional "error" = True
731 conditional "warning" = True
732 conditional _ = False
734 outCLine :: SourcePos -> String
735 outCLine (SourcePos name line) =
736 "# "++show line++" \""++showCString (snd (splitName name))++"\"\n"
738 outHsLine :: SourcePos -> String
739 outHsLine (SourcePos name line) =
740 " hsc_line ("++show (line + 1)++", \""++
741 showCString (snd (splitName name))++"\");\n"
743 showCString :: String -> String
744 showCString = concatMap showCChar
746 showCChar '\"' = "\\\""
747 showCChar '\'' = "\\\'"
748 showCChar '?' = "\\?"
749 showCChar '\\' = "\\\\"
750 showCChar c | c >= ' ' && c <= '~' = [c]
751 showCChar '\a' = "\\a"
752 showCChar '\b' = "\\b"
753 showCChar '\f' = "\\f"
754 showCChar '\n' = "\\n\"\n \""
755 showCChar '\r' = "\\r"
756 showCChar '\t' = "\\t"
757 showCChar '\v' = "\\v"
759 intToDigit (ord c `quot` 64),
760 intToDigit (ord c `quot` 8 `mod` 8),
761 intToDigit (ord c `mod` 8)]