1 {-# OPTIONS -fffi -cpp #-}
3 ------------------------------------------------------------------------
4 -- $Id: Main.hs,v 1.74 2005/05/18 09:43:50 simonmar 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 defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
15 #include "../../includes/ghcconfig.h"
18 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114 || __HUGS__
19 import System.Console.GetOpt
24 import System (getProgName, getArgs, ExitCode(..), exitWith)
25 import Directory (removeFile,doesFileExist)
26 import Monad (MonadPlus(..), liftM, liftM2, when)
27 import Char (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
28 import List (intersperse, isSuffixOf)
29 import IO (hPutStr, hPutStrLn, stderr)
31 #if defined(mingw32_HOST_OS) && !__HUGS__
33 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
34 import Foreign.C.String
41 #if __GLASGOW_HASKELL__ >= 604
42 import System.Process ( runProcess, waitForProcess )
43 import System.IO ( openFile, IOMode(..), hClose )
44 #define HAVE_runProcess
47 #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
48 import Compat.RawSystem ( rawSystem )
49 #define HAVE_rawSystem
50 #elif __HUGS__ || __NHC__ >= 117
51 import System.Cmd ( rawSystem )
52 #define HAVE_rawSystem
55 #if !defined(HAVE_runProcess) || !defined(HAVE_rawSystem)
57 #if __HUGS__ || __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600
58 import System.Cmd ( system )
60 import System ( system )
65 version = "hsc2hs version 0.66\n"
77 | Define String (Maybe String)
81 template_flag :: Flag -> Bool
82 template_flag (Template _) = True
83 template_flag _ = False
85 include :: String -> Flag
86 include s@('\"':_) = Include s
87 include s@('<' :_) = Include s
88 include s = Include ("\""++s++"\"")
90 define :: String -> Flag
91 define s = case break (== '=') s of
92 (name, []) -> Define name Nothing
93 (name, _:value) -> Define name (Just value)
95 options :: [OptDescr Flag]
97 Option ['o'] ["output"] (ReqArg Output "FILE")
98 "name of main output file",
99 Option ['t'] ["template"] (ReqArg Template "FILE")
101 Option ['c'] ["cc"] (ReqArg Compiler "PROG")
103 Option ['l'] ["ld"] (ReqArg Linker "PROG")
105 Option ['C'] ["cflag"] (ReqArg CompFlag "FLAG")
106 "flag to pass to the C compiler",
107 Option ['I'] [] (ReqArg (CompFlag . ("-I"++)) "DIR")
108 "passed to the C compiler",
109 Option ['L'] ["lflag"] (ReqArg LinkFlag "FLAG")
110 "flag to pass to the linker",
111 Option ['i'] ["include"] (ReqArg include "FILE")
112 "as if placed in the source",
113 Option ['D'] ["define"] (ReqArg define "NAME[=VALUE]")
114 "as if placed in the source",
115 Option [] ["no-compile"] (NoArg NoCompile)
116 "stop after writing *_hsc_make.c",
117 Option ['v'] ["verbose"] (NoArg Verbose)
118 "dump commands to stderr",
119 Option ['?'] ["help"] (NoArg Help)
120 "display this help and exit",
121 Option ['V'] ["version"] (NoArg Version)
122 "output version information and exit" ]
127 prog <- getProgramName
128 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
130 let (flags, files, errs) = getOpt Permute options args
132 -- If there is no Template flag explicitly specified, try
133 -- to find one by looking near the executable. This only
134 -- works on Win32 or Hugs (getExecDir). On Unix, there's a wrapper
135 -- script which specifies an explicit template flag.
136 flags_w_tpl <- if any template_flag flags then
140 do mb_path <- getExecDir "/Main.hs"
142 do mb_path <- getExecDir "/bin/hsc2hs.exe"
148 let templ = path ++ "/template-hsc.h"
149 flg <- doesFileExist templ
151 then return ((Template templ):)
153 return (add_opt flags)
154 case (files, errs) of
156 | any isHelp flags_w_tpl -> bye (usageInfo header options)
157 | any isVersion flags_w_tpl -> bye version
159 isHelp Help = True; isHelp _ = False
160 isVersion Version = True; isVersion _ = False
161 ((_:_), []) -> mapM_ (processFile flags_w_tpl) files
162 (_, _ ) -> die (concat errs ++ usageInfo header options)
164 getProgramName :: IO String
165 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
166 where str `withoutSuffix` suff
167 | suff `isSuffixOf` str = take (length str - length suff) str
170 bye :: String -> IO a
171 bye s = putStr s >> exitWith ExitSuccess
173 die :: String -> IO a
174 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
176 processFile :: [Flag] -> String -> IO ()
177 processFile flags name
178 = do let file_name = dosifyPath name
179 s <- readFile file_name
181 Parser p -> case p (SourcePos file_name 1) s of
182 Success _ _ _ toks -> output flags file_name toks
183 Failure (SourcePos name' line) msg ->
184 die (name'++":"++show line++": "++msg++"\n")
186 ------------------------------------------------------------------------
187 -- A deterministic parser which remembers the text which has been parsed.
189 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
191 data ParseResult a = Success !SourcePos String String a
192 | Failure !SourcePos String
194 data SourcePos = SourcePos String !Int
196 updatePos :: SourcePos -> Char -> SourcePos
197 updatePos pos@(SourcePos name line) ch = case ch of
198 '\n' -> SourcePos name (line + 1)
201 instance Monad Parser where
202 return a = Parser $ \pos s -> Success pos [] s a
204 Parser $ \pos s -> case m pos s of
205 Success pos' out1 s' a -> case k a of
206 Parser k' -> case k' pos' s' of
207 Success pos'' out2 imp'' b ->
208 Success pos'' (out1++out2) imp'' b
209 Failure pos'' msg -> Failure pos'' msg
210 Failure pos' msg -> Failure pos' msg
211 fail msg = Parser $ \pos _ -> Failure pos msg
213 instance MonadPlus Parser where
215 Parser m `mplus` Parser n =
216 Parser $ \pos s -> case m pos s of
217 success@(Success _ _ _ _) -> success
218 Failure _ _ -> n pos s
220 getPos :: Parser SourcePos
221 getPos = Parser $ \pos s -> Success pos [] s pos
223 setPos :: SourcePos -> Parser ()
224 setPos pos = Parser $ \_ s -> Success pos [] s ()
226 message :: Parser a -> String -> Parser a
227 Parser m `message` msg =
228 Parser $ \pos s -> case m pos s of
229 success@(Success _ _ _ _) -> success
230 Failure pos' _ -> Failure pos' msg
232 catchOutput_ :: Parser a -> Parser String
233 catchOutput_ (Parser m) =
234 Parser $ \pos s -> case m pos s of
235 Success pos' out s' _ -> Success pos' [] s' out
236 Failure pos' msg -> Failure pos' msg
238 fakeOutput :: Parser a -> String -> Parser a
239 Parser m `fakeOutput` out =
240 Parser $ \pos s -> case m pos s of
241 Success pos' _ s' a -> Success pos' out s' a
242 Failure pos' msg -> Failure pos' msg
244 lookAhead :: Parser String
245 lookAhead = Parser $ \pos s -> Success pos [] s s
247 satisfy :: (Char -> Bool) -> Parser Char
249 Parser $ \pos s -> case s of
250 c:cs | p c -> Success (updatePos pos c) [c] cs c
251 _ -> Failure pos "Bad character"
253 char_ :: Char -> Parser ()
255 satisfy (== c) `message` (show c++" expected")
258 anyChar_ :: Parser ()
260 satisfy (const True) `message` "Unexpected end of file"
263 any2Chars_ :: Parser ()
264 any2Chars_ = anyChar_ >> anyChar_
266 many :: Parser a -> Parser [a]
267 many p = many1 p `mplus` return []
269 many1 :: Parser a -> Parser [a]
270 many1 p = liftM2 (:) p (many p)
272 many_ :: Parser a -> Parser ()
273 many_ p = many1_ p `mplus` return ()
275 many1_ :: Parser a -> Parser ()
276 many1_ p = p >> many_ p
278 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
279 manySatisfy = many . satisfy
280 manySatisfy1 = many1 . satisfy
282 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
283 manySatisfy_ = many_ . satisfy
284 manySatisfy1_ = many1_ . satisfy
286 ------------------------------------------------------------------------
287 -- Parser of hsc syntax.
290 = Text SourcePos String
291 | Special SourcePos String String
293 parser :: Parser [Token]
296 t <- catchOutput_ text
300 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
301 return (if null t then rest else Text pos t : rest)
308 c:_ | isAlpha c || c == '_' -> do
310 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
312 c:_ | isHsSymbol c -> do
313 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
316 '-':'-':symb' | all (== '-') symb' -> do
317 return () `fakeOutput` symb
318 manySatisfy_ (/= '\n')
321 return () `fakeOutput` unescapeHashes symb
323 '\"':_ -> do anyChar_; hsString '\"'; text
324 '\'':_ -> do anyChar_; hsString '\''; text
325 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
326 _:_ -> do anyChar_; text
328 hsString :: Char -> Parser ()
333 c:_ | c == quote -> anyChar_
338 char_ '\\' `mplus` return ()
340 | otherwise -> do any2Chars_; hsString quote
341 _:_ -> do anyChar_; hsString quote
343 hsComment :: Parser ()
348 '-':'}':_ -> any2Chars_
349 '{':'-':_ -> do any2Chars_; hsComment; hsComment
350 _:_ -> do anyChar_; hsComment
352 linePragma :: Parser ()
356 satisfy (\c -> c == 'L' || c == 'l')
357 satisfy (\c -> c == 'I' || c == 'i')
358 satisfy (\c -> c == 'N' || c == 'n')
359 satisfy (\c -> c == 'E' || c == 'e')
360 manySatisfy1_ isSpace
361 line <- liftM read $ manySatisfy1 isDigit
362 manySatisfy1_ isSpace
364 name <- manySatisfy (/= '\"')
370 setPos (SourcePos name (line - 1))
372 isHsSymbol :: Char -> Bool
373 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
374 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
375 isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True
376 isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True
377 isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True
378 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
379 isHsSymbol '~' = True
382 unescapeHashes :: String -> String
383 unescapeHashes [] = []
384 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
385 unescapeHashes (c:s) = c : unescapeHashes s
387 lookAheadC :: Parser String
388 lookAheadC = liftM joinLines lookAhead
391 joinLines ('\\':'\n':s) = joinLines s
392 joinLines (c:s) = c : joinLines s
394 satisfyC :: (Char -> Bool) -> Parser Char
398 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
401 charC_ :: Char -> Parser ()
403 satisfyC (== c) `message` (show c++" expected")
406 anyCharC_ :: Parser ()
408 satisfyC (const True) `message` "Unexpected end of file"
411 any2CharsC_ :: Parser ()
412 any2CharsC_ = anyCharC_ >> anyCharC_
414 manySatisfyC :: (Char -> Bool) -> Parser String
415 manySatisfyC = many . satisfyC
417 manySatisfyC_ :: (Char -> Bool) -> Parser ()
418 manySatisfyC_ = many_ . satisfyC
420 special :: Parser Token
422 manySatisfyC_ (\c -> isSpace c && c /= '\n')
427 manySatisfyC_ isSpace
428 sp <- keyArg (== '\n')
431 _ -> keyArg (const False)
433 keyArg :: (Char -> Bool) -> Parser Token
436 key <- keyword `message` "hsc keyword or '{' expected"
437 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
438 arg <- catchOutput_ (argument eol)
439 return (Special pos key arg)
441 keyword :: Parser String
443 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
444 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
447 argument :: (Char -> Bool) -> Parser ()
452 c:_ | eol c -> do anyCharC_; argument eol
454 '\"':_ -> do anyCharC_; cString '\"'; argument eol
455 '\'':_ -> do anyCharC_; cString '\''; argument eol
456 '(':_ -> do anyCharC_; nested ')'; argument eol
458 '/':'*':_ -> do any2CharsC_; cComment; argument eol
460 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
461 '[':_ -> do anyCharC_; nested ']'; argument eol
463 '{':_ -> do anyCharC_; nested '}'; argument eol
465 _:_ -> do anyCharC_; argument eol
467 nested :: Char -> Parser ()
468 nested c = do argument (== '\n'); charC_ c
470 cComment :: Parser ()
475 '*':'/':_ -> do any2CharsC_
476 _:_ -> do anyCharC_; cComment
478 cString :: Char -> Parser ()
483 c:_ | c == quote -> anyCharC_
484 '\\':_:_ -> do any2CharsC_; cString quote
485 _:_ -> do anyCharC_; cString quote
487 ------------------------------------------------------------------------
488 -- Write the output files.
490 splitName :: String -> (String, String)
492 case break (== '/') name of
493 (file, []) -> ([], file)
494 (dir, sep:rest) -> (dir++sep:restDir, restFile)
496 (restDir, restFile) = splitName rest
498 splitExt :: String -> (String, String)
500 case break (== '.') name of
501 (base, []) -> (base, [])
502 (base, sepRest@(sep:rest))
503 | null restExt -> (base, sepRest)
504 | otherwise -> (base++sep:restBase, restExt)
506 (restBase, restExt) = splitExt rest
508 output :: [Flag] -> String -> [Token] -> IO ()
509 output flags name toks = do
511 (outName, outDir, outBase) <- case [f | Output f <- flags] of
512 [] -> if not (null ext) && last ext == 'c'
513 then return (dir++base++init ext, dir, base)
516 then return (dir++base++"_out.hs", dir, base)
517 else return (dir++base++".hs", dir, base)
519 (dir, file) = splitName name
520 (base, ext) = splitExt file
522 (dir, file) = splitName f
523 (base, _) = splitExt file
524 in return (f, dir, base)
525 _ -> onlyOne "output file"
527 let cProgName = outDir++outBase++"_hsc_make.c"
528 oProgName = outDir++outBase++"_hsc_make.o"
529 progName = outDir++outBase++"_hsc_make"
530 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
531 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
532 -- via GHC has changed a few times, so this seems to be the only way... :-P * * *
535 outHFile = outBase++"_hsc.h"
536 outHName = outDir++outHFile
537 outCName = outDir++outBase++"_hsc.c"
539 beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
542 | null outDir = dosifyPath ("./" ++ progName)
543 | otherwise = progName
545 let specials = [(pos, key, arg) | Special pos key arg <- toks]
547 let needsC = any (\(_, key, _) -> key == "def") specials
550 let includeGuard = map fixChar outHName
552 fixChar c | isAlphaNum c = toUpper c
556 compiler <- case [c | Compiler c <- flags] of
559 _ -> onlyOne "compiler"
561 linker <- case [l | Linker l <- flags] of
562 [] -> return compiler
564 _ -> onlyOne "linker"
566 -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
567 -- Returns a native-format path
569 mb <- getExecDir "bin/hsc2hs.exe"
571 Nothing -> return def
573 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
574 flg <- doesFileExist ghc_path
579 -- On a Win32 installation we execute the hsc2hs binary directly,
580 -- with no --cc flags, so we'll call locateGhc here, which will
581 -- succeed, via getExecDir.
583 -- On a Unix installation, we'll run the wrapper script hsc2hs.sh
584 -- (called plain hsc2hs in the installed tree), which will pass
585 -- a suitable C compiler via --cc
587 -- The in-place installation always uses the wrapper script,
588 -- (called hsc2hs-inplace, generated from hsc2hs.sh)
589 compiler <- case [c | Compiler c <- flags] of
590 [] -> locateGhc "ghc"
592 _ -> onlyOne "compiler"
594 linker <- case [l | Linker l <- flags] of
595 [] -> locateGhc compiler
597 _ -> onlyOne "linker"
600 writeFile cProgName $
601 concatMap outFlagHeaderCProg flags++
602 concatMap outHeaderCProg specials++
603 "\nint main (int argc, char *argv [])\n{\n"++
604 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
605 outHsLine (SourcePos name 0)++
606 concatMap outTokenHs toks++
609 -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
610 -- so we use something slightly more complicated. :-P
611 when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
616 compilerStatus <- rawSystemL beVerbose compiler
618 ++ [f | CompFlag f <- flags]
623 case compilerStatus of
624 e@(ExitFailure _) -> exitWith e
628 linkerStatus <- rawSystemL beVerbose linker
629 ( [f | LinkFlag f <- flags]
635 e@(ExitFailure _) -> exitWith e
639 progStatus <- rawSystemWithStdOutL beVerbose execProgName [] outName
642 e@(ExitFailure _) -> exitWith e
645 when needsH $ writeFile outHName $
646 "#ifndef "++includeGuard++"\n" ++
647 "#define "++includeGuard++"\n" ++
648 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
649 "#include <Rts.h>\n" ++
651 "#include <HsFFI.h>\n" ++
654 "#define HsChar int\n" ++
656 concatMap outFlagH flags++
657 concatMap outTokenH specials++
660 when needsC $ writeFile outCName $
661 "#include \""++outHFile++"\"\n"++
662 concatMap outTokenC specials
663 -- NB. outHFile not outHName; works better when processed
664 -- by gcc or mkdependC.
666 rawSystemL :: Bool -> FilePath -> [String] -> IO ExitCode
667 rawSystemL flg prog args = do
668 let cmdLine = prog++" "++unwords args
669 when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
670 #ifndef HAVE_rawSystem
676 rawSystemWithStdOutL :: Bool -> FilePath -> [String] -> FilePath -> IO ExitCode
677 rawSystemWithStdOutL flg prog args outFile = do
678 let cmdLine = prog++" "++unwords args++" >"++outFile
679 when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
680 #ifndef HAVE_runProcess
683 hOut <- openFile outFile WriteMode
684 process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
685 res <- waitForProcess process
690 onlyOne :: String -> IO a
691 onlyOne what = die ("Only one "++what++" may be specified\n")
693 outFlagHeaderCProg :: Flag -> String
694 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
695 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
696 outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n"
697 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
698 outFlagHeaderCProg _ = ""
700 outHeaderCProg :: (SourcePos, String, String) -> String
701 outHeaderCProg (pos, key, arg) = case key of
702 "include" -> outCLine pos++"#include "++arg++"\n"
703 "define" -> outCLine pos++"#define "++arg++"\n"
704 "undef" -> outCLine pos++"#undef "++arg++"\n"
706 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
707 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
709 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
710 "let" -> case break (== '=') arg of
712 (header, _:body) -> case break isSpace header of
715 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
716 "printf ("++joinLines body++");\n"
719 joinLines = concat . intersperse " \\\n" . lines
721 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
722 outHeaderHs flags inH toks =
724 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
725 " printf (\"{-# OPTIONS -optc-D" ++
726 "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
727 "__GLASGOW_HASKELL__);\n" ++
730 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
731 Just f -> outInclude ("\""++f++"\"")
733 outFlag (Include f) = outInclude f
734 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
735 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
737 outSpecial (pos, key, arg) = case key of
738 "include" -> outInclude arg
739 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
741 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
743 goodForOptD arg = case arg of
745 c:_ | isSpace c -> True
748 toOptD arg = case break isSpace arg of
750 (name, _:value) -> name++'=':dropWhile isSpace value
752 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
753 " printf (\"{-# OPTIONS %s #-}\\n\", \""++
754 showCString s++"\");\n"++
756 " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
757 showCString s++"\");\n"++
760 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
761 " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++
762 showCString s++"\");\n"++
764 " printf (\"{-# INCLUDE %s #-}\\n\", \""++
765 showCString s++"\");\n"++
768 outTokenHs :: Token -> String
769 outTokenHs (Text pos txt) =
770 case break (== '\n') txt of
771 (allTxt, []) -> outText allTxt
773 outText (first++"\n")++
777 outText s = " fputs (\""++showCString s++"\", stdout);\n"
778 outTokenHs (Special pos key arg) =
784 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
786 "enum" -> outCLine pos++outEnum arg
787 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
789 outEnum :: String -> String
791 case break (== ',') arg of
793 (t, _:afterT) -> case break (== ',') afterT of
796 enums (_:s) = case break (== ',') s of
798 this = case break (== '=') $ dropWhile isSpace enum of
800 " hsc_enum ("++t++", "++f++", " ++
801 "hsc_haskellize (\""++name++"\"), "++
804 " hsc_enum ("++t++", "++f++", " ++
805 "printf (\"%s\", \""++hsName++"\"), "++
810 outFlagH :: Flag -> String
811 outFlagH (Include f) = "#include "++f++"\n"
812 outFlagH (Define n Nothing) = "#define "++n++" 1\n"
813 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
816 outTokenH :: (SourcePos, String, String) -> String
817 outTokenH (pos, key, arg) =
819 "include" -> outCLine pos++"#include "++arg++"\n"
820 "define" -> outCLine pos++"#define " ++arg++"\n"
821 "undef" -> outCLine pos++"#undef " ++arg++"\n"
822 "def" -> outCLine pos++case arg of
823 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
824 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
825 'i':'n':'l':'i':'n':'e':' ':_ ->
826 "#ifdef __GNUC__\n" ++
830 _ -> "extern "++header++";\n"
831 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
832 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
835 outTokenC :: (SourcePos, String, String) -> String
836 outTokenC (pos, key, arg) =
839 's':'t':'r':'u':'c':'t':' ':_ -> ""
840 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
841 'i':'n':'l':'i':'n':'e':' ':arg' ->
842 case span (\c -> c /= '{' && c /= '=') arg' of
845 "#ifndef __GNUC__\n" ++
849 "\n#ifndef __GNUC__\n" ++
854 _ -> outCLine pos++arg++"\n"
855 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
858 conditional :: String -> Bool
859 conditional "if" = True
860 conditional "ifdef" = True
861 conditional "ifndef" = True
862 conditional "elif" = True
863 conditional "else" = True
864 conditional "endif" = True
865 conditional "error" = True
866 conditional "warning" = True
867 conditional _ = False
869 outCLine :: SourcePos -> String
870 outCLine (SourcePos name line) =
871 "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
873 outHsLine :: SourcePos -> String
874 outHsLine (SourcePos name line) =
875 " hsc_line ("++show (line + 1)++", \""++
876 showCString (snd (splitName name))++"\");\n"
878 showCString :: String -> String
879 showCString = concatMap showCChar
881 showCChar '\"' = "\\\""
882 showCChar '\'' = "\\\'"
883 showCChar '?' = "\\?"
884 showCChar '\\' = "\\\\"
885 showCChar c | c >= ' ' && c <= '~' = [c]
886 showCChar '\a' = "\\a"
887 showCChar '\b' = "\\b"
888 showCChar '\f' = "\\f"
889 showCChar '\n' = "\\n\"\n \""
890 showCChar '\r' = "\\r"
891 showCChar '\t' = "\\t"
892 showCChar '\v' = "\\v"
894 intToDigit (ord c `quot` 64),
895 intToDigit (ord c `quot` 8 `mod` 8),
896 intToDigit (ord c `mod` 8)]
900 -----------------------------------------
901 -- Cut and pasted from ghc/compiler/SysTools
902 -- Convert paths foo/baz to foo\baz on Windows
904 dosifyPath, unDosifyPath :: String -> String
905 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
906 dosifyPath xs = subst '/' '\\' xs
907 unDosifyPath xs = subst '\\' '/' xs
909 subst :: Eq a => a -> a -> [a] -> [a]
910 subst a b ls = map (\ x -> if x == a then b else x) ls
916 getExecDir :: String -> IO (Maybe String)
917 -- (getExecDir cmd) returns the directory in which the current
918 -- executable, which should be called 'cmd', is running
919 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
920 -- you'll get "/a/b/c" back as the result
925 return (Just (reverse (drop (length cmd) (reverse (unDosifyPath s)))))
926 #elif defined(mingw32_HOST_OS)
928 = allocaArray len $ \buf -> do
929 ret <- getModuleFileName nullPtr buf len
930 if ret == 0 then return Nothing
931 else do s <- peekCString buf
932 return (Just (reverse (drop (length cmd)
933 (reverse (unDosifyPath s)))))
935 len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
937 foreign import stdcall unsafe "GetModuleFileNameA"
938 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
941 getExecDir _ = return Nothing