1 {-# OPTIONS -fglasgow-exts #-}
3 ------------------------------------------------------------------------
4 -- $Id: Main.hs,v 1.43 2002/10/29 10:50:54 simonpj Exp $
6 -- Program for converting .hsc files to .hs files, by converting the
7 -- file into a C program which is run to generate the Haskell source.
8 -- Certain items known only to the C compiler can then be used in
9 -- the Haskell module; for example #defined constants, byte offsets
10 -- within structures, etc.
12 -- See the documentation in the Users' Guide for more details.
14 #if __GLASGOW_HASKELL__ >= 504
15 import System.Console.GetOpt
21 import System (getProgName, getArgs, ExitCode(..), exitWith, exitFailure, system)
22 import Directory (removeFile)
23 import Monad (MonadPlus(..), liftM, liftM2, when, unless)
24 import Char (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
25 import List (intersperse)
27 #include "../../includes/config.h"
29 #ifdef mingw32_HOST_OS
32 #if __GLASGOW_HASKELL__ >= 504
33 import Foreign.C.String
42 version = "hsc2hs-0.65"
54 | Define String (Maybe String)
57 template_flag (Template _) = True
58 template_flag _ = False
60 include :: String -> Flag
61 include s@('\"':_) = Include s
62 include s@('<' :_) = Include s
63 include s = Include ("\""++s++"\"")
65 define :: String -> Flag
66 define s = case break (== '=') s of
67 (name, []) -> Define name Nothing
68 (name, _:value) -> Define name (Just value)
70 options :: [OptDescr Flag]
72 Option "t" ["template"] (ReqArg Template "FILE") "template file",
73 Option "c" ["cc"] (ReqArg Compiler "PROG") "C compiler to use",
74 Option "l" ["ld"] (ReqArg Linker "PROG") "linker to use",
75 Option "C" ["cflag"] (ReqArg CompFlag "FLAG") "flag to pass to the C compiler",
76 Option "I" [] (ReqArg (CompFlag . ("-I"++))
77 "DIR") "passed to the C compiler",
78 Option "L" ["lflag"] (ReqArg LinkFlag "FLAG") "flag to pass to the linker",
79 Option "i" ["include"] (ReqArg include "FILE") "as if placed in the source",
80 Option "D" ["define"] (ReqArg define "NAME[=VALUE]") "as if placed in the source",
81 Option "o" ["output"] (ReqArg Output "FILE") "name of main output file",
82 Option "" ["help"] (NoArg Help) "display this help and exit",
83 Option "" ["version"] (NoArg Version) "output version information and exit",
84 Option "" ["no-compile"] (NoArg NoCompile) "stop after writing *_hsc_make.c"]
89 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]"
91 let (flags, files, errs) = getOpt Permute options args
93 -- If there is no Template flag explicitly specified, try
94 -- to find one by looking near the executable. This only
95 -- works on Win32 (getExecDir). On Unix, there's a wrapper
96 -- script which specifies an explicit template flag.
97 flags_w_tpl <- if any template_flag flags then
100 do { mb_path <- getExecDir "/bin/hsc2hs.exe" ;
102 Nothing -> return flags
104 Just path -> return (Template path : flags) }
106 case (files, errs) of
108 | any isHelp flags_w_tpl -> putStrLn (usageInfo header options)
109 | any isVersion flags_w_tpl -> putStrLn version
111 isHelp Help = True; isHelp _ = False
112 isVersion Version = True; isVersion _ = False
113 ([], []) -> putStrLn (prog++": No input files")
114 (files, []) -> mapM_ (processFile flags_w_tpl) files
115 (_, errs) -> do { mapM_ putStrLn errs ;
116 putStrLn (usageInfo header options) ;
119 processFile :: [Flag] -> String -> IO ()
120 processFile flags name
121 = do let file_name = dosifyPath name
122 s <- readFile file_name
124 Parser p -> case p (SourcePos file_name 1) s of
125 Success _ _ _ toks -> output flags file_name toks
126 Failure (SourcePos name' line) msg -> do
127 putStrLn (name'++":"++show line++": "++msg)
130 ------------------------------------------------------------------------
131 -- A deterministic parser which remembers the text which has been parsed.
133 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
135 data ParseResult a = Success !SourcePos String String a
136 | Failure !SourcePos String
138 data SourcePos = SourcePos String !Int
140 updatePos :: SourcePos -> Char -> SourcePos
141 updatePos pos@(SourcePos name line) ch = case ch of
142 '\n' -> SourcePos name (line + 1)
145 instance Monad Parser where
146 return a = Parser $ \pos s -> Success pos [] s a
148 Parser $ \pos s -> case m pos s of
149 Success pos' out1 s' a -> case k a of
150 Parser k' -> case k' pos' s' of
151 Success pos'' out2 imp'' b ->
152 Success pos'' (out1++out2) imp'' b
153 Failure pos'' msg -> Failure pos'' msg
154 Failure pos' msg -> Failure pos' msg
155 fail msg = Parser $ \pos _ -> Failure pos msg
157 instance MonadPlus Parser where
159 Parser m `mplus` Parser n =
160 Parser $ \pos s -> case m pos s of
161 success@(Success _ _ _ _) -> success
162 Failure _ _ -> n pos s
164 getPos :: Parser SourcePos
165 getPos = Parser $ \pos s -> Success pos [] s pos
167 setPos :: SourcePos -> Parser ()
168 setPos pos = Parser $ \_ s -> Success pos [] s ()
170 message :: Parser a -> String -> Parser a
171 Parser m `message` msg =
172 Parser $ \pos s -> case m pos s of
173 success@(Success _ _ _ _) -> success
174 Failure pos' _ -> Failure pos' msg
176 catchOutput_ :: Parser a -> Parser String
177 catchOutput_ (Parser m) =
178 Parser $ \pos s -> case m pos s of
179 Success pos' out s' _ -> Success pos' [] s' out
180 Failure pos' msg -> Failure pos' msg
182 fakeOutput :: Parser a -> String -> Parser a
183 Parser m `fakeOutput` out =
184 Parser $ \pos s -> case m pos s of
185 Success pos' _ s' a -> Success pos' out s' a
186 Failure pos' msg -> Failure pos' msg
188 lookAhead :: Parser String
189 lookAhead = Parser $ \pos s -> Success pos [] s s
191 satisfy :: (Char -> Bool) -> Parser Char
193 Parser $ \pos s -> case s of
194 c:cs | p c -> Success (updatePos pos c) [c] cs c
195 _ -> Failure pos "Bad character"
197 char_ :: Char -> Parser ()
199 satisfy (== c) `message` (show c++" expected")
202 anyChar_ :: Parser ()
204 satisfy (const True) `message` "Unexpected end of file"
207 any2Chars_ :: Parser ()
208 any2Chars_ = anyChar_ >> anyChar_
210 many :: Parser a -> Parser [a]
211 many p = many1 p `mplus` return []
213 many1 :: Parser a -> Parser [a]
214 many1 p = liftM2 (:) p (many p)
216 many_ :: Parser a -> Parser ()
217 many_ p = many1_ p `mplus` return ()
219 many1_ :: Parser a -> Parser ()
220 many1_ p = p >> many_ p
222 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
223 manySatisfy = many . satisfy
224 manySatisfy1 = many1 . satisfy
226 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
227 manySatisfy_ = many_ . satisfy
228 manySatisfy1_ = many1_ . satisfy
230 ------------------------------------------------------------------------
231 -- Parser of hsc syntax.
234 = Text SourcePos String
235 | Special SourcePos String String
237 parser :: Parser [Token]
240 t <- catchOutput_ text
244 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
245 return (if null t then rest else Text pos t : rest)
252 c:_ | isAlpha c || c == '_' -> do
254 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
256 c:_ | isHsSymbol c -> do
257 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
260 '-':'-':symb' | all (== '-') symb' -> do
261 return () `fakeOutput` symb
262 manySatisfy_ (/= '\n')
265 return () `fakeOutput` unescapeHashes symb
267 '\"':_ -> do anyChar_; hsString '\"'; text
268 '\'':_ -> do anyChar_; hsString '\''; text
269 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
270 _:_ -> do anyChar_; text
272 hsString :: Char -> Parser ()
277 c:_ | c == quote -> anyChar_
282 char_ '\\' `mplus` return ()
284 | otherwise -> do any2Chars_; hsString quote
285 _:_ -> do anyChar_; hsString quote
287 hsComment :: Parser ()
292 '-':'}':_ -> any2Chars_
293 '{':'-':_ -> do any2Chars_; hsComment; hsComment
294 _:_ -> do anyChar_; hsComment
296 linePragma :: Parser ()
300 satisfy (\c -> c == 'L' || c == 'l')
301 satisfy (\c -> c == 'I' || c == 'i')
302 satisfy (\c -> c == 'N' || c == 'n')
303 satisfy (\c -> c == 'E' || c == 'e')
304 manySatisfy1_ isSpace
305 line <- liftM read $ manySatisfy1 isDigit
306 manySatisfy1_ isSpace
308 name <- manySatisfy (/= '\"')
314 setPos (SourcePos name (line - 1))
316 isHsSymbol :: Char -> Bool
317 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
318 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
319 isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True
320 isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True
321 isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True
322 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
323 isHsSymbol '~' = True
326 unescapeHashes :: String -> String
327 unescapeHashes [] = []
328 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
329 unescapeHashes (c:s) = c : unescapeHashes s
331 lookAheadC :: Parser String
332 lookAheadC = liftM joinLines lookAhead
335 joinLines ('\\':'\n':s) = joinLines s
336 joinLines (c:s) = c : joinLines s
338 satisfyC :: (Char -> Bool) -> Parser Char
342 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
345 charC_ :: Char -> Parser ()
347 satisfyC (== c) `message` (show c++" expected")
350 anyCharC_ :: Parser ()
352 satisfyC (const True) `message` "Unexpected end of file"
355 any2CharsC_ :: Parser ()
356 any2CharsC_ = anyCharC_ >> anyCharC_
358 manySatisfyC :: (Char -> Bool) -> Parser String
359 manySatisfyC = many . satisfyC
361 manySatisfyC_ :: (Char -> Bool) -> Parser ()
362 manySatisfyC_ = many_ . satisfyC
364 special :: Parser Token
366 manySatisfyC_ (\c -> isSpace c && c /= '\n')
371 manySatisfyC_ isSpace
372 sp <- keyArg (== '\n')
375 _ -> keyArg (const False)
377 keyArg :: (Char -> Bool) -> Parser Token
380 key <- keyword `message` "hsc keyword or '{' expected"
381 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
382 arg <- catchOutput_ (argument eol)
383 return (Special pos key arg)
385 keyword :: Parser String
387 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
388 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
391 argument :: (Char -> Bool) -> Parser ()
396 c:_ | eol c -> do anyCharC_; argument eol
398 '\"':_ -> do anyCharC_; cString '\"'; argument eol
399 '\'':_ -> do anyCharC_; cString '\''; argument eol
400 '(':_ -> do anyCharC_; nested ')'; argument eol
402 '/':'*':_ -> do any2CharsC_; cComment; argument eol
404 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
405 '[':_ -> do anyCharC_; nested ']'; argument eol
407 '{':_ -> do anyCharC_; nested '}'; argument eol
409 _:_ -> do anyCharC_; argument eol
411 nested :: Char -> Parser ()
412 nested c = do argument (== '\n'); charC_ c
414 cComment :: Parser ()
419 '*':'/':_ -> do any2CharsC_
420 _:_ -> do anyCharC_; cComment
422 cString :: Char -> Parser ()
427 c:_ | c == quote -> anyCharC_
428 '\\':_:_ -> do any2CharsC_; cString quote
429 _:_ -> do anyCharC_; cString quote
431 ------------------------------------------------------------------------
432 -- Write the output files.
434 splitName :: String -> (String, String)
436 case break (== '/') name of
437 (file, []) -> ([], file)
438 (dir, sep:rest) -> (dir++sep:restDir, restFile)
440 (restDir, restFile) = splitName rest
442 splitExt :: String -> (String, String)
444 case break (== '.') name of
445 (base, []) -> (base, [])
446 (base, sepRest@(sep:rest))
447 | null restExt -> (base, sepRest)
448 | otherwise -> (base++sep:restBase, restExt)
450 (restBase, restExt) = splitExt rest
452 output :: [Flag] -> String -> [Token] -> IO ()
453 output flags name toks = do
455 (outName, outDir, outBase) <- case [f | Output f <- flags] of
458 last ext == 'c' -> return (dir++base++init ext, dir, base)
459 | ext == ".hs" -> return (dir++base++"_out.hs", dir, base)
460 | otherwise -> return (dir++base++".hs", dir, base)
462 (dir, file) = splitName name
463 (base, ext) = splitExt file
465 (dir, file) = splitName f
466 (base, _) = splitExt file
467 in return (f, dir, base)
468 _ -> onlyOne "output file"
470 let cProgName = outDir++outBase++"_hsc_make.c"
471 oProgName = outDir++outBase++"_hsc_make.o"
472 progName = outDir++outBase++"_hsc_make" ++ progNameSuffix
473 outHFile = outBase++"_hsc.h"
474 outHName = outDir++outHFile
475 outCName = outDir++outBase++"_hsc.c"
478 | null outDir = '.':pathSep:progName
479 | otherwise = progName
481 let specials = [(pos, key, arg) | Special pos key arg <- toks]
483 let needsC = any (\(_, key, _) -> key == "def") specials
486 let includeGuard = map fixChar outHName
488 fixChar c | isAlphaNum c = toUpper c
491 compiler <- case [c | Compiler c <- flags] of
494 _ -> onlyOne "compiler"
496 linker <- case [l | Linker l <- flags] of
499 _ -> onlyOne "linker"
501 writeFile cProgName $
502 concatMap outFlagHeaderCProg flags++
503 concatMap outHeaderCProg specials++
504 "\nint main (void)\n{\n"++
505 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
506 outHsLine (SourcePos name 0)++
507 concatMap outTokenHs toks++
510 unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess
512 compilerStatus <- system $
515 concat [" "++f | CompFlag f <- flags]++
518 case compilerStatus of
519 e@(ExitFailure _) -> exitWith e
523 linkerStatus <- system $
525 concat [" "++f | LinkFlag f <- flags]++
529 e@(ExitFailure _) -> exitWith e
533 progStatus <- system (execProgName++" >"++outName)
536 e@(ExitFailure _) -> exitWith e
539 when needsH $ writeFile outHName $
540 "#ifndef "++includeGuard++"\n\
541 \#define "++includeGuard++"\n\
543 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
546 \#include <HsFFI.h>\n\
549 \#define HsChar int\n\
551 concatMap outFlagH flags++
552 concatMap outTokenH specials++
555 when needsC $ writeFile outCName $
556 "#include \""++outHFile++"\"\n"++
557 concatMap outTokenC specials
558 -- NB. outHFile not outHName; works better when processed
559 -- by gcc or mkdependC.
561 onlyOne :: String -> IO a
563 putStrLn ("Only one "++what++" may be specified")
566 outFlagHeaderCProg :: Flag -> String
567 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
568 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
569 outFlagHeaderCProg (Define n Nothing) = "#define "++n++"\n"
570 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
571 outFlagHeaderCProg _ = ""
573 outHeaderCProg :: (SourcePos, String, String) -> String
574 outHeaderCProg (pos, key, arg) = case key of
575 "include" -> outCLine pos++"#include "++arg++"\n"
576 "define" -> outCLine pos++"#define "++arg++"\n"
577 "undef" -> outCLine pos++"#undef "++arg++"\n"
579 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
580 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
582 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
583 "let" -> case break (== '=') arg of
585 (header, _:body) -> case break isSpace header of
588 "#define hsc_"++name++"("++dropWhile isSpace args++") \
589 \printf ("++joinLines body++");\n"
592 joinLines = concat . intersperse " \\\n" . lines
594 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
595 outHeaderHs flags inH toks =
597 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
598 \ printf (\"{-# OPTIONS -optc-D" ++
599 "__GLASGOW_HASKELL__=%d #-}\\n\", \
600 \__GLASGOW_HASKELL__);\n\
603 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
604 Just f -> outOption ("-#include \""++f++"\"")
606 outFlag (Include f) = outOption ("-#include "++f)
607 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
608 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
610 outSpecial (pos, key, arg) = case key of
611 "include" -> outOption ("-#include "++arg)
612 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
614 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
616 goodForOptD arg = case arg of
618 c:_ | isSpace c -> True
621 toOptD arg = case break isSpace arg of
623 (name, _:value) -> name++'=':dropWhile isSpace value
624 outOption s = " printf (\"{-# OPTIONS %s #-}\\n\", \""++
625 showCString s++"\");\n"
627 outTokenHs :: Token -> String
628 outTokenHs (Text pos text) =
629 case break (== '\n') text of
630 (all, []) -> outText all
632 outText (first++"\n")++
636 outText s = " fputs (\""++showCString s++"\", stdout);\n"
637 outTokenHs (Special pos key arg) =
643 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
645 "enum" -> outCLine pos++outEnum arg
646 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
648 outEnum :: String -> String
650 case break (== ',') arg of
652 (t, _:afterT) -> case break (== ',') afterT of
655 enums (_:s) = case break (== ',') s of
657 this = case break (== '=') $ dropWhile isSpace enum of
659 " hsc_enum ("++t++", "++f++", \
660 \hsc_haskellize (\""++name++"\"), "++
663 " hsc_enum ("++t++", "++f++", \
664 \printf (\"%s\", \""++hsName++"\"), "++
669 outFlagH :: Flag -> String
670 outFlagH (Include f) = "#include "++f++"\n"
671 outFlagH (Define n Nothing) = "#define "++n++"\n"
672 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
675 outTokenH :: (SourcePos, String, String) -> String
676 outTokenH (pos, key, arg) =
678 "include" -> outCLine pos++"#include "++arg++"\n"
679 "define" -> outCLine pos++"#define " ++arg++"\n"
680 "undef" -> outCLine pos++"#undef " ++arg++"\n"
681 "def" -> outCLine pos++case arg of
682 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
683 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
684 'i':'n':'l':'i':'n':'e':' ':_ ->
689 _ -> "extern "++header++";\n"
690 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
691 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
694 outTokenC :: (SourcePos, String, String) -> String
695 outTokenC (pos, key, arg) =
698 's':'t':'r':'u':'c':'t':' ':_ -> ""
699 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
700 'i':'n':'l':'i':'n':'e':' ':arg' ->
701 case span (\c -> c /= '{' && c /= '=') arg' of
708 "\n#ifndef __GNUC__\n\
713 _ -> outCLine pos++arg++"\n"
714 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
717 conditional :: String -> Bool
718 conditional "if" = True
719 conditional "ifdef" = True
720 conditional "ifndef" = True
721 conditional "elif" = True
722 conditional "else" = True
723 conditional "endif" = True
724 conditional "error" = True
725 conditional "warning" = True
726 conditional _ = False
728 outCLine :: SourcePos -> String
729 outCLine (SourcePos name line) =
730 "# "++show line++" \""++showCString (snd (splitName name))++"\"\n"
732 outHsLine :: SourcePos -> String
733 outHsLine (SourcePos name line) =
734 " hsc_line ("++show (line + 1)++", \""++
735 showCString (snd (splitName name))++"\");\n"
737 showCString :: String -> String
738 showCString = concatMap showCChar
740 showCChar '\"' = "\\\""
741 showCChar '\'' = "\\\'"
742 showCChar '?' = "\\?"
743 showCChar '\\' = "\\\\"
744 showCChar c | c >= ' ' && c <= '~' = [c]
745 showCChar '\a' = "\\a"
746 showCChar '\b' = "\\b"
747 showCChar '\f' = "\\f"
748 showCChar '\n' = "\\n\"\n \""
749 showCChar '\r' = "\\r"
750 showCChar '\t' = "\\t"
751 showCChar '\v' = "\\v"
753 intToDigit (ord c `quot` 64),
754 intToDigit (ord c `quot` 8 `mod` 8),
755 intToDigit (ord c `mod` 8)]
759 -----------------------------------------
760 -- Cut and pasted from ghc/compiler/SysTools
761 -- Convert paths foo/baz to foo\baz on Windows
764 #if defined(mingw32_HOST_OS)
765 subst a b ls = map (\ x -> if x == a then b else x) ls
766 unDosifyPath xs = subst '\\' '/' xs
767 dosifyPath xs = subst '/' '\\' xs
769 getExecDir :: String -> IO (Maybe String)
770 -- (getExecDir cmd) returns the directory in which the current
771 -- executable, which should be called 'cmd', is running
772 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
773 -- you'll get "/a/b/c" back as the result
775 = allocaArray len $ \buf -> do
776 ret <- getModuleFileName nullPtr buf len
777 if ret == 0 then return Nothing
778 else do s <- peekCString buf
779 return (Just (reverse (drop (length cmd)
780 (reverse (unDosifyPath s)))))
782 len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
784 foreign import stdcall "GetModuleFileNameA" unsafe
785 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
790 getExecDir :: String -> IO (Maybe String)
791 getExecDir s = do return Nothing