1 {-# OPTIONS -fffi -cpp #-}
3 ------------------------------------------------------------------------
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 defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
13 #include "../../includes/ghcconfig.h"
16 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
17 import System.Console.GetOpt
22 import System (getProgName, getArgs, ExitCode(..), exitWith)
23 import Directory (removeFile,doesFileExist)
24 import Monad (MonadPlus(..), liftM, liftM2, when)
25 import Char (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
26 import List (intersperse, isSuffixOf)
27 import IO (hPutStr, hPutStrLn, stderr)
29 #if defined(mingw32_HOST_OS)
31 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
32 import Foreign.C.String
38 #if __GLASGOW_HASKELL__ >= 604
39 import System.Process ( runProcess, waitForProcess )
40 import System.IO ( openFile, IOMode(..), hClose )
41 #define HAVE_runProcess
44 #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
45 import Compat.RawSystem ( rawSystem )
46 #define HAVE_rawSystem
48 import System.Cmd ( rawSystem )
49 #define HAVE_rawSystem
52 #if !defined(HAVE_runProcess) || !defined(HAVE_rawSystem)
54 #if __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600
55 import System.Cmd ( system )
57 import System ( system )
62 version = "hsc2hs version 0.66\n"
74 | Define String (Maybe String)
78 template_flag :: Flag -> Bool
79 template_flag (Template _) = True
80 template_flag _ = False
82 include :: String -> Flag
83 include s@('\"':_) = Include s
84 include s@('<' :_) = Include s
85 include s = Include ("\""++s++"\"")
87 define :: String -> Flag
88 define s = case break (== '=') s of
89 (name, []) -> Define name Nothing
90 (name, _:value) -> Define name (Just value)
92 options :: [OptDescr Flag]
94 Option ['o'] ["output"] (ReqArg Output "FILE")
95 "name of main output file",
96 Option ['t'] ["template"] (ReqArg Template "FILE")
98 Option ['c'] ["cc"] (ReqArg Compiler "PROG")
100 Option ['l'] ["ld"] (ReqArg Linker "PROG")
102 Option ['C'] ["cflag"] (ReqArg CompFlag "FLAG")
103 "flag to pass to the C compiler",
104 Option ['I'] [] (ReqArg (CompFlag . ("-I"++)) "DIR")
105 "passed to the C compiler",
106 Option ['L'] ["lflag"] (ReqArg LinkFlag "FLAG")
107 "flag to pass to the linker",
108 Option ['i'] ["include"] (ReqArg include "FILE")
109 "as if placed in the source",
110 Option ['D'] ["define"] (ReqArg define "NAME[=VALUE]")
111 "as if placed in the source",
112 Option [] ["no-compile"] (NoArg NoCompile)
113 "stop after writing *_hsc_make.c",
114 Option ['v'] ["verbose"] (NoArg Verbose)
115 "dump commands to stderr",
116 Option ['?'] ["help"] (NoArg Help)
117 "display this help and exit",
118 Option ['V'] ["version"] (NoArg Version)
119 "output version information and exit" ]
123 prog <- getProgramName
124 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
126 let (flags, files, errs) = getOpt Permute options args
128 -- If there is no Template flag explicitly specified, try
129 -- to find one by looking near the executable. This only
130 -- works on Win32 or Hugs (getExecDir). On Unix, there's a wrapper
131 -- script which specifies an explicit template flag.
132 flags_w_tpl <- if any template_flag flags then
135 do mb_path <- getExecDir "/bin/hsc2hs.exe"
140 let templ = path ++ "/template-hsc.h"
141 flg <- doesFileExist templ
143 then return ((Template templ):)
145 return (add_opt flags)
146 case (files, errs) of
148 | any isHelp flags_w_tpl -> bye (usageInfo header options)
149 | any isVersion flags_w_tpl -> bye version
151 isHelp Help = True; isHelp _ = False
152 isVersion Version = True; isVersion _ = False
153 ((_:_), []) -> mapM_ (processFile flags_w_tpl) files
154 (_, _ ) -> die (concat errs ++ usageInfo header options)
156 getProgramName :: IO String
157 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
158 where str `withoutSuffix` suff
159 | suff `isSuffixOf` str = take (length str - length suff) str
162 bye :: String -> IO a
163 bye s = putStr s >> exitWith ExitSuccess
165 die :: String -> IO a
166 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
168 processFile :: [Flag] -> String -> IO ()
169 processFile flags name
170 = do let file_name = dosifyPath name
171 s <- readFile file_name
173 Parser p -> case p (SourcePos file_name 1) s of
174 Success _ _ _ toks -> output flags file_name toks
175 Failure (SourcePos name' line) msg ->
176 die (name'++":"++show line++": "++msg++"\n")
178 ------------------------------------------------------------------------
179 -- A deterministic parser which remembers the text which has been parsed.
181 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
183 data ParseResult a = Success !SourcePos String String a
184 | Failure !SourcePos String
186 data SourcePos = SourcePos String !Int
188 updatePos :: SourcePos -> Char -> SourcePos
189 updatePos pos@(SourcePos name line) ch = case ch of
190 '\n' -> SourcePos name (line + 1)
193 instance Monad Parser where
194 return a = Parser $ \pos s -> Success pos [] s a
196 Parser $ \pos s -> case m pos s of
197 Success pos' out1 s' a -> case k a of
198 Parser k' -> case k' pos' s' of
199 Success pos'' out2 imp'' b ->
200 Success pos'' (out1++out2) imp'' b
201 Failure pos'' msg -> Failure pos'' msg
202 Failure pos' msg -> Failure pos' msg
203 fail msg = Parser $ \pos _ -> Failure pos msg
205 instance MonadPlus Parser where
207 Parser m `mplus` Parser n =
208 Parser $ \pos s -> case m pos s of
209 success@(Success _ _ _ _) -> success
210 Failure _ _ -> n pos s
212 getPos :: Parser SourcePos
213 getPos = Parser $ \pos s -> Success pos [] s pos
215 setPos :: SourcePos -> Parser ()
216 setPos pos = Parser $ \_ s -> Success pos [] s ()
218 message :: Parser a -> String -> Parser a
219 Parser m `message` msg =
220 Parser $ \pos s -> case m pos s of
221 success@(Success _ _ _ _) -> success
222 Failure pos' _ -> Failure pos' msg
224 catchOutput_ :: Parser a -> Parser String
225 catchOutput_ (Parser m) =
226 Parser $ \pos s -> case m pos s of
227 Success pos' out s' _ -> Success pos' [] s' out
228 Failure pos' msg -> Failure pos' msg
230 fakeOutput :: Parser a -> String -> Parser a
231 Parser m `fakeOutput` out =
232 Parser $ \pos s -> case m pos s of
233 Success pos' _ s' a -> Success pos' out s' a
234 Failure pos' msg -> Failure pos' msg
236 lookAhead :: Parser String
237 lookAhead = Parser $ \pos s -> Success pos [] s s
239 satisfy :: (Char -> Bool) -> Parser Char
241 Parser $ \pos s -> case s of
242 c:cs | p c -> Success (updatePos pos c) [c] cs c
243 _ -> Failure pos "Bad character"
245 char_ :: Char -> Parser ()
247 satisfy (== c) `message` (show c++" expected")
250 anyChar_ :: Parser ()
252 satisfy (const True) `message` "Unexpected end of file"
255 any2Chars_ :: Parser ()
256 any2Chars_ = anyChar_ >> anyChar_
258 many :: Parser a -> Parser [a]
259 many p = many1 p `mplus` return []
261 many1 :: Parser a -> Parser [a]
262 many1 p = liftM2 (:) p (many p)
264 many_ :: Parser a -> Parser ()
265 many_ p = many1_ p `mplus` return ()
267 many1_ :: Parser a -> Parser ()
268 many1_ p = p >> many_ p
270 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
271 manySatisfy = many . satisfy
272 manySatisfy1 = many1 . satisfy
274 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
275 manySatisfy_ = many_ . satisfy
276 manySatisfy1_ = many1_ . satisfy
278 ------------------------------------------------------------------------
279 -- Parser of hsc syntax.
282 = Text SourcePos String
283 | Special SourcePos String String
285 parser :: Parser [Token]
288 t <- catchOutput_ text
292 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
293 return (if null t then rest else Text pos t : rest)
300 c:_ | isAlpha c || c == '_' -> do
302 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
304 c:_ | isHsSymbol c -> do
305 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
308 '-':'-':symb' | all (== '-') symb' -> do
309 return () `fakeOutput` symb
310 manySatisfy_ (/= '\n')
313 return () `fakeOutput` unescapeHashes symb
315 '\"':_ -> do anyChar_; hsString '\"'; text
316 '\'':_ -> do anyChar_; hsString '\''; text
317 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
318 _:_ -> do anyChar_; text
320 hsString :: Char -> Parser ()
325 c:_ | c == quote -> anyChar_
330 char_ '\\' `mplus` return ()
332 | otherwise -> do any2Chars_; hsString quote
333 _:_ -> do anyChar_; hsString quote
335 hsComment :: Parser ()
340 '-':'}':_ -> any2Chars_
341 '{':'-':_ -> do any2Chars_; hsComment; hsComment
342 _:_ -> do anyChar_; hsComment
344 linePragma :: Parser ()
348 satisfy (\c -> c == 'L' || c == 'l')
349 satisfy (\c -> c == 'I' || c == 'i')
350 satisfy (\c -> c == 'N' || c == 'n')
351 satisfy (\c -> c == 'E' || c == 'e')
352 manySatisfy1_ isSpace
353 line <- liftM read $ manySatisfy1 isDigit
354 manySatisfy1_ isSpace
356 name <- manySatisfy (/= '\"')
362 setPos (SourcePos name (line - 1))
364 isHsSymbol :: Char -> Bool
365 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
366 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
367 isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True
368 isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True
369 isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True
370 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
371 isHsSymbol '~' = True
374 unescapeHashes :: String -> String
375 unescapeHashes [] = []
376 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
377 unescapeHashes (c:s) = c : unescapeHashes s
379 lookAheadC :: Parser String
380 lookAheadC = liftM joinLines lookAhead
383 joinLines ('\\':'\n':s) = joinLines s
384 joinLines (c:s) = c : joinLines s
386 satisfyC :: (Char -> Bool) -> Parser Char
390 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
393 charC_ :: Char -> Parser ()
395 satisfyC (== c) `message` (show c++" expected")
398 anyCharC_ :: Parser ()
400 satisfyC (const True) `message` "Unexpected end of file"
403 any2CharsC_ :: Parser ()
404 any2CharsC_ = anyCharC_ >> anyCharC_
406 manySatisfyC :: (Char -> Bool) -> Parser String
407 manySatisfyC = many . satisfyC
409 manySatisfyC_ :: (Char -> Bool) -> Parser ()
410 manySatisfyC_ = many_ . satisfyC
412 special :: Parser Token
414 manySatisfyC_ (\c -> isSpace c && c /= '\n')
419 manySatisfyC_ isSpace
420 sp <- keyArg (== '\n')
423 _ -> keyArg (const False)
425 keyArg :: (Char -> Bool) -> Parser Token
428 key <- keyword `message` "hsc keyword or '{' expected"
429 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
430 arg <- catchOutput_ (argument eol)
431 return (Special pos key arg)
433 keyword :: Parser String
435 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
436 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
439 argument :: (Char -> Bool) -> Parser ()
444 c:_ | eol c -> do anyCharC_; argument eol
446 '\"':_ -> do anyCharC_; cString '\"'; argument eol
447 '\'':_ -> do anyCharC_; cString '\''; argument eol
448 '(':_ -> do anyCharC_; nested ')'; argument eol
450 '/':'*':_ -> do any2CharsC_; cComment; argument eol
452 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
453 '[':_ -> do anyCharC_; nested ']'; argument eol
455 '{':_ -> do anyCharC_; nested '}'; argument eol
457 _:_ -> do anyCharC_; argument eol
459 nested :: Char -> Parser ()
460 nested c = do argument (== '\n'); charC_ c
462 cComment :: Parser ()
467 '*':'/':_ -> do any2CharsC_
468 _:_ -> do anyCharC_; cComment
470 cString :: Char -> Parser ()
475 c:_ | c == quote -> anyCharC_
476 '\\':_:_ -> do any2CharsC_; cString quote
477 _:_ -> do anyCharC_; cString quote
479 ------------------------------------------------------------------------
480 -- Write the output files.
482 splitName :: String -> (String, String)
484 case break (== '/') name of
485 (file, []) -> ([], file)
486 (dir, sep:rest) -> (dir++sep:restDir, restFile)
488 (restDir, restFile) = splitName rest
490 splitExt :: String -> (String, String)
492 case break (== '.') name of
493 (base, []) -> (base, [])
494 (base, sepRest@(sep:rest))
495 | null restExt -> (base, sepRest)
496 | otherwise -> (base++sep:restBase, restExt)
498 (restBase, restExt) = splitExt rest
500 output :: [Flag] -> String -> [Token] -> IO ()
501 output flags name toks = do
503 (outName, outDir, outBase) <- case [f | Output f <- flags] of
504 [] -> if not (null ext) && last ext == 'c'
505 then return (dir++base++init ext, dir, base)
508 then return (dir++base++"_out.hs", dir, base)
509 else return (dir++base++".hs", dir, base)
511 (dir, file) = splitName name
512 (base, ext) = splitExt file
514 (dir, file) = splitName f
515 (base, _) = splitExt file
516 in return (f, dir, base)
517 _ -> onlyOne "output file"
519 let cProgName = outDir++outBase++"_hsc_make.c"
520 oProgName = outDir++outBase++"_hsc_make.o"
521 progName = outDir++outBase++"_hsc_make"
522 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
523 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
524 -- via GHC has changed a few times, so this seems to be the only way... :-P * * *
527 outHFile = outBase++"_hsc.h"
528 outHName = outDir++outHFile
529 outCName = outDir++outBase++"_hsc.c"
531 beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
534 | null outDir = dosifyPath ("./" ++ progName)
535 | otherwise = progName
537 let specials = [(pos, key, arg) | Special pos key arg <- toks]
539 let needsC = any (\(_, key, _) -> key == "def") specials
542 let includeGuard = map fixChar outHName
544 fixChar c | isAlphaNum c = toUpper c
547 -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
548 -- Returns a native-format path
550 mb <- getExecDir "bin/hsc2hs.exe"
552 Nothing -> return def
554 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
555 flg <- doesFileExist ghc_path
560 -- On a Win32 installation we execute the hsc2hs binary directly,
561 -- with no --cc flags, so we'll call locateGhc here, which will
562 -- succeed, via getExecDir.
564 -- On a Unix installation, we'll run the wrapper script hsc2hs.sh
565 -- (called plain hsc2hs in the installed tree), which will pass
566 -- a suitable C compiler via --cc
568 -- The in-place installation always uses the wrapper script,
569 -- (called hsc2hs-inplace, generated from hsc2hs.sh)
570 compiler <- case [c | Compiler c <- flags] of
571 [] -> locateGhc "ghc"
573 _ -> onlyOne "compiler"
575 linker <- case [l | Linker l <- flags] of
576 [] -> locateGhc compiler
578 _ -> onlyOne "linker"
580 writeFile cProgName $
581 concatMap outFlagHeaderCProg flags++
582 concatMap outHeaderCProg specials++
583 "\nint main (int argc, char *argv [])\n{\n"++
584 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
585 outHsLine (SourcePos name 0)++
586 concatMap outTokenHs toks++
589 -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
590 -- so we use something slightly more complicated. :-P
591 when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
594 rawSystemL ("compiling " ++ cProgName) beVerbose compiler
596 ++ [f | CompFlag f <- flags]
602 rawSystemL ("linking " ++ oProgName) beVerbose linker
603 ( [f | LinkFlag f <- flags]
609 rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
612 when needsH $ writeFile outHName $
613 "#ifndef "++includeGuard++"\n" ++
614 "#define "++includeGuard++"\n" ++
615 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
616 "#include <Rts.h>\n" ++
618 "#include <HsFFI.h>\n" ++
621 "#define HsChar int\n" ++
623 concatMap outFlagH flags++
624 concatMap outTokenH specials++
627 when needsC $ writeFile outCName $
628 "#include \""++outHFile++"\"\n"++
629 concatMap outTokenC specials
630 -- NB. outHFile not outHName; works better when processed
631 -- by gcc or mkdependC.
633 rawSystemL :: String -> Bool -> FilePath -> [String] -> IO ()
634 rawSystemL action flg prog args = do
635 let cmdLine = prog++" "++unwords args
636 when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
637 #ifndef HAVE_rawSystem
638 exitStatus <- system cmdLine
640 exitStatus <- rawSystem prog args
643 ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
646 rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
647 rawSystemWithStdOutL action flg prog args outFile = do
648 let cmdLine = prog++" "++unwords args++" >"++outFile
649 when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
650 #ifndef HAVE_runProcess
651 exitStatus <- system cmdLine
653 hOut <- openFile outFile WriteMode
654 process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
655 exitStatus <- waitForProcess process
659 ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
662 onlyOne :: String -> IO a
663 onlyOne what = die ("Only one "++what++" may be specified\n")
665 outFlagHeaderCProg :: Flag -> String
666 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
667 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
668 outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n"
669 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
670 outFlagHeaderCProg _ = ""
672 outHeaderCProg :: (SourcePos, String, String) -> String
673 outHeaderCProg (pos, key, arg) = case key of
674 "include" -> outCLine pos++"#include "++arg++"\n"
675 "define" -> outCLine pos++"#define "++arg++"\n"
676 "undef" -> outCLine pos++"#undef "++arg++"\n"
678 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
679 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
681 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
682 "let" -> case break (== '=') arg of
684 (header, _:body) -> case break isSpace header of
687 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
688 "printf ("++joinLines body++");\n"
691 joinLines = concat . intersperse " \\\n" . lines
693 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
694 outHeaderHs flags inH toks =
696 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
697 " printf (\"{-# OPTIONS -optc-D" ++
698 "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
699 "__GLASGOW_HASKELL__);\n" ++
702 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
703 Just f -> outInclude ("\""++f++"\"")
705 outFlag (Include f) = outInclude f
706 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
707 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
709 outSpecial (pos, key, arg) = case key of
710 "include" -> outInclude arg
711 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
713 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
715 goodForOptD arg = case arg of
717 c:_ | isSpace c -> True
720 toOptD arg = case break isSpace arg of
722 (name, _:value) -> name++'=':dropWhile isSpace value
724 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
725 " printf (\"{-# OPTIONS %s #-}\\n\", \""++
726 showCString s++"\");\n"++
728 " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
729 showCString s++"\");\n"++
732 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
733 " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++
734 showCString s++"\");\n"++
736 " printf (\"{-# INCLUDE %s #-}\\n\", \""++
737 showCString s++"\");\n"++
740 outTokenHs :: Token -> String
741 outTokenHs (Text pos txt) =
742 case break (== '\n') txt of
743 (allTxt, []) -> outText allTxt
745 outText (first++"\n")++
749 outText s = " fputs (\""++showCString s++"\", stdout);\n"
750 outTokenHs (Special pos key arg) =
756 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
758 "enum" -> outCLine pos++outEnum arg
759 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
761 outEnum :: String -> String
763 case break (== ',') arg of
765 (t, _:afterT) -> case break (== ',') afterT of
768 enums (_:s) = case break (== ',') s of
770 this = case break (== '=') $ dropWhile isSpace enum of
772 " hsc_enum ("++t++", "++f++", " ++
773 "hsc_haskellize (\""++name++"\"), "++
776 " hsc_enum ("++t++", "++f++", " ++
777 "printf (\"%s\", \""++hsName++"\"), "++
782 outFlagH :: Flag -> String
783 outFlagH (Include f) = "#include "++f++"\n"
784 outFlagH (Define n Nothing) = "#define "++n++" 1\n"
785 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
788 outTokenH :: (SourcePos, String, String) -> String
789 outTokenH (pos, key, arg) =
791 "include" -> outCLine pos++"#include "++arg++"\n"
792 "define" -> outCLine pos++"#define " ++arg++"\n"
793 "undef" -> outCLine pos++"#undef " ++arg++"\n"
794 "def" -> outCLine pos++case arg of
795 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
796 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
797 'i':'n':'l':'i':'n':'e':' ':_ ->
798 "#ifdef __GNUC__\n" ++
802 _ -> "extern "++header++";\n"
803 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
804 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
807 outTokenC :: (SourcePos, String, String) -> String
808 outTokenC (pos, key, arg) =
811 's':'t':'r':'u':'c':'t':' ':_ -> ""
812 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
813 'i':'n':'l':'i':'n':'e':' ':arg' ->
814 case span (\c -> c /= '{' && c /= '=') arg' of
817 "#ifndef __GNUC__\n" ++
821 "\n#ifndef __GNUC__\n" ++
826 _ -> outCLine pos++arg++"\n"
827 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
830 conditional :: String -> Bool
831 conditional "if" = True
832 conditional "ifdef" = True
833 conditional "ifndef" = True
834 conditional "elif" = True
835 conditional "else" = True
836 conditional "endif" = True
837 conditional "error" = True
838 conditional "warning" = True
839 conditional _ = False
841 outCLine :: SourcePos -> String
842 outCLine (SourcePos name line) =
843 "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
845 outHsLine :: SourcePos -> String
846 outHsLine (SourcePos name line) =
847 " hsc_line ("++show (line + 1)++", \""++
848 showCString name++"\");\n"
850 showCString :: String -> String
851 showCString = concatMap showCChar
853 showCChar '\"' = "\\\""
854 showCChar '\'' = "\\\'"
855 showCChar '?' = "\\?"
856 showCChar '\\' = "\\\\"
857 showCChar c | c >= ' ' && c <= '~' = [c]
858 showCChar '\a' = "\\a"
859 showCChar '\b' = "\\b"
860 showCChar '\f' = "\\f"
861 showCChar '\n' = "\\n\"\n \""
862 showCChar '\r' = "\\r"
863 showCChar '\t' = "\\t"
864 showCChar '\v' = "\\v"
866 intToDigit (ord c `quot` 64),
867 intToDigit (ord c `quot` 8 `mod` 8),
868 intToDigit (ord c `mod` 8)]
870 -----------------------------------------
871 -- Modified version from ghc/compiler/SysTools
872 -- Convert paths foo/baz to foo\baz on Windows
874 subst :: Char -> Char -> String -> String
875 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
876 subst a b = map (\x -> if x == a then b else x)
881 dosifyPath :: String -> String
882 dosifyPath = subst '/' '\\'
884 -- (getExecDir cmd) returns the directory in which the current
885 -- executable, which should be called 'cmd', is running
886 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
887 -- you'll get "/a/b/c" back as the result
888 getExecDir :: String -> IO (Maybe String)
890 getExecPath >>= maybe (return Nothing) removeCmdSuffix
891 where unDosifyPath = subst '\\' '/'
892 initN n = reverse . drop n . reverse
893 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
895 getExecPath :: IO (Maybe String)
896 #if defined(mingw32_HOST_OS)
898 allocaArray len $ \buf -> do
899 ret <- getModuleFileName nullPtr buf len
900 if ret == 0 then return Nothing
901 else liftM Just $ peekCString buf
902 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
904 foreign import stdcall unsafe "GetModuleFileNameA"
905 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
907 getExecPath = return Nothing