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 || __HUGS__
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) && !__HUGS__
31 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
32 import Foreign.C.String
39 #if __GLASGOW_HASKELL__ >= 604
40 import System.Process ( runProcess, waitForProcess )
41 import System.IO ( openFile, IOMode(..), hClose )
42 #define HAVE_runProcess
45 #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
46 import Compat.RawSystem ( rawSystem )
47 #define HAVE_rawSystem
48 #elif __HUGS__ || __NHC__ >= 117
49 import System.Cmd ( rawSystem )
50 #define HAVE_rawSystem
53 #if !defined(HAVE_runProcess) || !defined(HAVE_rawSystem)
55 #if __HUGS__ || __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600
56 import System.Cmd ( system )
58 import System ( system )
63 version = "hsc2hs version 0.66\n"
75 | Define String (Maybe String)
79 template_flag :: Flag -> Bool
80 template_flag (Template _) = True
81 template_flag _ = False
83 include :: String -> Flag
84 include s@('\"':_) = Include s
85 include s@('<' :_) = Include s
86 include s = Include ("\""++s++"\"")
88 define :: String -> Flag
89 define s = case break (== '=') s of
90 (name, []) -> Define name Nothing
91 (name, _:value) -> Define name (Just value)
93 options :: [OptDescr Flag]
95 Option ['o'] ["output"] (ReqArg Output "FILE")
96 "name of main output file",
97 Option ['t'] ["template"] (ReqArg Template "FILE")
99 Option ['c'] ["cc"] (ReqArg Compiler "PROG")
101 Option ['l'] ["ld"] (ReqArg Linker "PROG")
103 Option ['C'] ["cflag"] (ReqArg CompFlag "FLAG")
104 "flag to pass to the C compiler",
105 Option ['I'] [] (ReqArg (CompFlag . ("-I"++)) "DIR")
106 "passed to the C compiler",
107 Option ['L'] ["lflag"] (ReqArg LinkFlag "FLAG")
108 "flag to pass to the linker",
109 Option ['i'] ["include"] (ReqArg include "FILE")
110 "as if placed in the source",
111 Option ['D'] ["define"] (ReqArg define "NAME[=VALUE]")
112 "as if placed in the source",
113 Option [] ["no-compile"] (NoArg NoCompile)
114 "stop after writing *_hsc_make.c",
115 Option ['v'] ["verbose"] (NoArg Verbose)
116 "dump commands to stderr",
117 Option ['?'] ["help"] (NoArg Help)
118 "display this help and exit",
119 Option ['V'] ["version"] (NoArg Version)
120 "output version information and exit" ]
125 prog <- getProgramName
126 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
128 let (flags, files, errs) = getOpt Permute options args
130 -- If there is no Template flag explicitly specified, try
131 -- to find one by looking near the executable. This only
132 -- works on Win32 or Hugs (getExecDir). On Unix, there's a wrapper
133 -- script which specifies an explicit template flag.
134 flags_w_tpl <- if any template_flag flags then
138 do mb_path <- getExecDir "/Main.hs"
140 do mb_path <- getExecDir "/bin/hsc2hs.exe"
146 let templ = path ++ "/template-hsc.h"
147 flg <- doesFileExist templ
149 then return ((Template templ):)
151 return (add_opt flags)
152 case (files, errs) of
154 | any isHelp flags_w_tpl -> bye (usageInfo header options)
155 | any isVersion flags_w_tpl -> bye version
157 isHelp Help = True; isHelp _ = False
158 isVersion Version = True; isVersion _ = False
159 ((_:_), []) -> mapM_ (processFile flags_w_tpl) files
160 (_, _ ) -> die (concat errs ++ usageInfo header options)
162 getProgramName :: IO String
163 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
164 where str `withoutSuffix` suff
165 | suff `isSuffixOf` str = take (length str - length suff) str
168 bye :: String -> IO a
169 bye s = putStr s >> exitWith ExitSuccess
171 die :: String -> IO a
172 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
174 processFile :: [Flag] -> String -> IO ()
175 processFile flags name
176 = do let file_name = dosifyPath name
177 s <- readFile file_name
179 Parser p -> case p (SourcePos file_name 1) s of
180 Success _ _ _ toks -> output flags file_name toks
181 Failure (SourcePos name' line) msg ->
182 die (name'++":"++show line++": "++msg++"\n")
184 ------------------------------------------------------------------------
185 -- A deterministic parser which remembers the text which has been parsed.
187 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
189 data ParseResult a = Success !SourcePos String String a
190 | Failure !SourcePos String
192 data SourcePos = SourcePos String !Int
194 updatePos :: SourcePos -> Char -> SourcePos
195 updatePos pos@(SourcePos name line) ch = case ch of
196 '\n' -> SourcePos name (line + 1)
199 instance Monad Parser where
200 return a = Parser $ \pos s -> Success pos [] s a
202 Parser $ \pos s -> case m pos s of
203 Success pos' out1 s' a -> case k a of
204 Parser k' -> case k' pos' s' of
205 Success pos'' out2 imp'' b ->
206 Success pos'' (out1++out2) imp'' b
207 Failure pos'' msg -> Failure pos'' msg
208 Failure pos' msg -> Failure pos' msg
209 fail msg = Parser $ \pos _ -> Failure pos msg
211 instance MonadPlus Parser where
213 Parser m `mplus` Parser n =
214 Parser $ \pos s -> case m pos s of
215 success@(Success _ _ _ _) -> success
216 Failure _ _ -> n pos s
218 getPos :: Parser SourcePos
219 getPos = Parser $ \pos s -> Success pos [] s pos
221 setPos :: SourcePos -> Parser ()
222 setPos pos = Parser $ \_ s -> Success pos [] s ()
224 message :: Parser a -> String -> Parser a
225 Parser m `message` msg =
226 Parser $ \pos s -> case m pos s of
227 success@(Success _ _ _ _) -> success
228 Failure pos' _ -> Failure pos' msg
230 catchOutput_ :: Parser a -> Parser String
231 catchOutput_ (Parser m) =
232 Parser $ \pos s -> case m pos s of
233 Success pos' out s' _ -> Success pos' [] s' out
234 Failure pos' msg -> Failure pos' msg
236 fakeOutput :: Parser a -> String -> Parser a
237 Parser m `fakeOutput` out =
238 Parser $ \pos s -> case m pos s of
239 Success pos' _ s' a -> Success pos' out s' a
240 Failure pos' msg -> Failure pos' msg
242 lookAhead :: Parser String
243 lookAhead = Parser $ \pos s -> Success pos [] s s
245 satisfy :: (Char -> Bool) -> Parser Char
247 Parser $ \pos s -> case s of
248 c:cs | p c -> Success (updatePos pos c) [c] cs c
249 _ -> Failure pos "Bad character"
251 char_ :: Char -> Parser ()
253 satisfy (== c) `message` (show c++" expected")
256 anyChar_ :: Parser ()
258 satisfy (const True) `message` "Unexpected end of file"
261 any2Chars_ :: Parser ()
262 any2Chars_ = anyChar_ >> anyChar_
264 many :: Parser a -> Parser [a]
265 many p = many1 p `mplus` return []
267 many1 :: Parser a -> Parser [a]
268 many1 p = liftM2 (:) p (many p)
270 many_ :: Parser a -> Parser ()
271 many_ p = many1_ p `mplus` return ()
273 many1_ :: Parser a -> Parser ()
274 many1_ p = p >> many_ p
276 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
277 manySatisfy = many . satisfy
278 manySatisfy1 = many1 . satisfy
280 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
281 manySatisfy_ = many_ . satisfy
282 manySatisfy1_ = many1_ . satisfy
284 ------------------------------------------------------------------------
285 -- Parser of hsc syntax.
288 = Text SourcePos String
289 | Special SourcePos String String
291 parser :: Parser [Token]
294 t <- catchOutput_ text
298 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
299 return (if null t then rest else Text pos t : rest)
306 c:_ | isAlpha c || c == '_' -> do
308 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
310 c:_ | isHsSymbol c -> do
311 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
314 '-':'-':symb' | all (== '-') symb' -> do
315 return () `fakeOutput` symb
316 manySatisfy_ (/= '\n')
319 return () `fakeOutput` unescapeHashes symb
321 '\"':_ -> do anyChar_; hsString '\"'; text
322 '\'':_ -> do anyChar_; hsString '\''; text
323 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
324 _:_ -> do anyChar_; text
326 hsString :: Char -> Parser ()
331 c:_ | c == quote -> anyChar_
336 char_ '\\' `mplus` return ()
338 | otherwise -> do any2Chars_; hsString quote
339 _:_ -> do anyChar_; hsString quote
341 hsComment :: Parser ()
346 '-':'}':_ -> any2Chars_
347 '{':'-':_ -> do any2Chars_; hsComment; hsComment
348 _:_ -> do anyChar_; hsComment
350 linePragma :: Parser ()
354 satisfy (\c -> c == 'L' || c == 'l')
355 satisfy (\c -> c == 'I' || c == 'i')
356 satisfy (\c -> c == 'N' || c == 'n')
357 satisfy (\c -> c == 'E' || c == 'e')
358 manySatisfy1_ isSpace
359 line <- liftM read $ manySatisfy1 isDigit
360 manySatisfy1_ isSpace
362 name <- manySatisfy (/= '\"')
368 setPos (SourcePos name (line - 1))
370 isHsSymbol :: Char -> Bool
371 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
372 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
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
380 unescapeHashes :: String -> String
381 unescapeHashes [] = []
382 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
383 unescapeHashes (c:s) = c : unescapeHashes s
385 lookAheadC :: Parser String
386 lookAheadC = liftM joinLines lookAhead
389 joinLines ('\\':'\n':s) = joinLines s
390 joinLines (c:s) = c : joinLines s
392 satisfyC :: (Char -> Bool) -> Parser Char
396 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
399 charC_ :: Char -> Parser ()
401 satisfyC (== c) `message` (show c++" expected")
404 anyCharC_ :: Parser ()
406 satisfyC (const True) `message` "Unexpected end of file"
409 any2CharsC_ :: Parser ()
410 any2CharsC_ = anyCharC_ >> anyCharC_
412 manySatisfyC :: (Char -> Bool) -> Parser String
413 manySatisfyC = many . satisfyC
415 manySatisfyC_ :: (Char -> Bool) -> Parser ()
416 manySatisfyC_ = many_ . satisfyC
418 special :: Parser Token
420 manySatisfyC_ (\c -> isSpace c && c /= '\n')
425 manySatisfyC_ isSpace
426 sp <- keyArg (== '\n')
429 _ -> keyArg (const False)
431 keyArg :: (Char -> Bool) -> Parser Token
434 key <- keyword `message` "hsc keyword or '{' expected"
435 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
436 arg <- catchOutput_ (argument eol)
437 return (Special pos key arg)
439 keyword :: Parser String
441 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
442 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
445 argument :: (Char -> Bool) -> Parser ()
450 c:_ | eol c -> do anyCharC_; argument eol
452 '\"':_ -> do anyCharC_; cString '\"'; argument eol
453 '\'':_ -> do anyCharC_; cString '\''; argument eol
454 '(':_ -> do anyCharC_; nested ')'; argument eol
456 '/':'*':_ -> do any2CharsC_; cComment; argument eol
458 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
459 '[':_ -> do anyCharC_; nested ']'; argument eol
461 '{':_ -> do anyCharC_; nested '}'; argument eol
463 _:_ -> do anyCharC_; argument eol
465 nested :: Char -> Parser ()
466 nested c = do argument (== '\n'); charC_ c
468 cComment :: Parser ()
473 '*':'/':_ -> do any2CharsC_
474 _:_ -> do anyCharC_; cComment
476 cString :: Char -> Parser ()
481 c:_ | c == quote -> anyCharC_
482 '\\':_:_ -> do any2CharsC_; cString quote
483 _:_ -> do anyCharC_; cString quote
485 ------------------------------------------------------------------------
486 -- Write the output files.
488 splitName :: String -> (String, String)
490 case break (== '/') name of
491 (file, []) -> ([], file)
492 (dir, sep:rest) -> (dir++sep:restDir, restFile)
494 (restDir, restFile) = splitName rest
496 splitExt :: String -> (String, String)
498 case break (== '.') name of
499 (base, []) -> (base, [])
500 (base, sepRest@(sep:rest))
501 | null restExt -> (base, sepRest)
502 | otherwise -> (base++sep:restBase, restExt)
504 (restBase, restExt) = splitExt rest
506 output :: [Flag] -> String -> [Token] -> IO ()
507 output flags name toks = do
509 (outName, outDir, outBase) <- case [f | Output f <- flags] of
510 [] -> if not (null ext) && last ext == 'c'
511 then return (dir++base++init ext, dir, base)
514 then return (dir++base++"_out.hs", dir, base)
515 else return (dir++base++".hs", dir, base)
517 (dir, file) = splitName name
518 (base, ext) = splitExt file
520 (dir, file) = splitName f
521 (base, _) = splitExt file
522 in return (f, dir, base)
523 _ -> onlyOne "output file"
525 let cProgName = outDir++outBase++"_hsc_make.c"
526 oProgName = outDir++outBase++"_hsc_make.o"
527 progName = outDir++outBase++"_hsc_make"
528 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
529 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
530 -- via GHC has changed a few times, so this seems to be the only way... :-P * * *
533 outHFile = outBase++"_hsc.h"
534 outHName = outDir++outHFile
535 outCName = outDir++outBase++"_hsc.c"
537 beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
540 | null outDir = dosifyPath ("./" ++ progName)
541 | otherwise = progName
543 let specials = [(pos, key, arg) | Special pos key arg <- toks]
545 let needsC = any (\(_, key, _) -> key == "def") specials
548 let includeGuard = map fixChar outHName
550 fixChar c | isAlphaNum c = toUpper c
554 compiler <- case [c | Compiler c <- flags] of
557 _ -> onlyOne "compiler"
559 linker <- case [l | Linker l <- flags] of
560 [] -> return compiler
562 _ -> onlyOne "linker"
564 -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
565 -- Returns a native-format path
567 mb <- getExecDir "bin/hsc2hs.exe"
569 Nothing -> return def
571 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
572 flg <- doesFileExist ghc_path
577 -- On a Win32 installation we execute the hsc2hs binary directly,
578 -- with no --cc flags, so we'll call locateGhc here, which will
579 -- succeed, via getExecDir.
581 -- On a Unix installation, we'll run the wrapper script hsc2hs.sh
582 -- (called plain hsc2hs in the installed tree), which will pass
583 -- a suitable C compiler via --cc
585 -- The in-place installation always uses the wrapper script,
586 -- (called hsc2hs-inplace, generated from hsc2hs.sh)
587 compiler <- case [c | Compiler c <- flags] of
588 [] -> locateGhc "ghc"
590 _ -> onlyOne "compiler"
592 linker <- case [l | Linker l <- flags] of
593 [] -> locateGhc compiler
595 _ -> onlyOne "linker"
598 writeFile cProgName $
599 concatMap outFlagHeaderCProg flags++
600 concatMap outHeaderCProg specials++
601 "\nint main (int argc, char *argv [])\n{\n"++
602 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
603 outHsLine (SourcePos name 0)++
604 concatMap outTokenHs toks++
607 -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
608 -- so we use something slightly more complicated. :-P
609 when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
614 rawSystemL ("compiling " ++ cProgName) beVerbose compiler
616 ++ [f | CompFlag f <- flags]
622 rawSystemL ("linking " ++ oProgName) beVerbose linker
623 ( [f | LinkFlag f <- flags]
629 rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
632 when needsH $ writeFile outHName $
633 "#ifndef "++includeGuard++"\n" ++
634 "#define "++includeGuard++"\n" ++
635 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
636 "#include <Rts.h>\n" ++
638 "#include <HsFFI.h>\n" ++
641 "#define HsChar int\n" ++
643 concatMap outFlagH flags++
644 concatMap outTokenH specials++
647 when needsC $ writeFile outCName $
648 "#include \""++outHFile++"\"\n"++
649 concatMap outTokenC specials
650 -- NB. outHFile not outHName; works better when processed
651 -- by gcc or mkdependC.
653 rawSystemL :: String -> Bool -> FilePath -> [String] -> IO ()
654 rawSystemL action flg prog args = do
655 let cmdLine = prog++" "++unwords args
656 when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
657 #ifndef HAVE_rawSystem
658 exitStatus <- system cmdLine
660 exitStatus <- rawSystem prog args
663 ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
666 rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
667 rawSystemWithStdOutL action flg prog args outFile = do
668 let cmdLine = prog++" "++unwords args++" >"++outFile
669 when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
670 #ifndef HAVE_runProcess
671 exitStatus <- system cmdLine
673 hOut <- openFile outFile WriteMode
674 process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
675 exitStatus <- waitForProcess process
679 ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
682 onlyOne :: String -> IO a
683 onlyOne what = die ("Only one "++what++" may be specified\n")
685 outFlagHeaderCProg :: Flag -> String
686 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
687 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
688 outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n"
689 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
690 outFlagHeaderCProg _ = ""
692 outHeaderCProg :: (SourcePos, String, String) -> String
693 outHeaderCProg (pos, key, arg) = case key of
694 "include" -> outCLine pos++"#include "++arg++"\n"
695 "define" -> outCLine pos++"#define "++arg++"\n"
696 "undef" -> outCLine pos++"#undef "++arg++"\n"
698 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
699 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
701 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
702 "let" -> case break (== '=') arg of
704 (header, _:body) -> case break isSpace header of
707 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
708 "printf ("++joinLines body++");\n"
711 joinLines = concat . intersperse " \\\n" . lines
713 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
714 outHeaderHs flags inH toks =
716 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
717 " printf (\"{-# OPTIONS -optc-D" ++
718 "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
719 "__GLASGOW_HASKELL__);\n" ++
722 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
723 Just f -> outInclude ("\""++f++"\"")
725 outFlag (Include f) = outInclude f
726 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
727 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
729 outSpecial (pos, key, arg) = case key of
730 "include" -> outInclude arg
731 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
733 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
735 goodForOptD arg = case arg of
737 c:_ | isSpace c -> True
740 toOptD arg = case break isSpace arg of
742 (name, _:value) -> name++'=':dropWhile isSpace value
744 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
745 " printf (\"{-# OPTIONS %s #-}\\n\", \""++
746 showCString s++"\");\n"++
748 " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
749 showCString s++"\");\n"++
752 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
753 " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++
754 showCString s++"\");\n"++
756 " printf (\"{-# INCLUDE %s #-}\\n\", \""++
757 showCString s++"\");\n"++
760 outTokenHs :: Token -> String
761 outTokenHs (Text pos txt) =
762 case break (== '\n') txt of
763 (allTxt, []) -> outText allTxt
765 outText (first++"\n")++
769 outText s = " fputs (\""++showCString s++"\", stdout);\n"
770 outTokenHs (Special pos key arg) =
776 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
778 "enum" -> outCLine pos++outEnum arg
779 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
781 outEnum :: String -> String
783 case break (== ',') arg of
785 (t, _:afterT) -> case break (== ',') afterT of
788 enums (_:s) = case break (== ',') s of
790 this = case break (== '=') $ dropWhile isSpace enum of
792 " hsc_enum ("++t++", "++f++", " ++
793 "hsc_haskellize (\""++name++"\"), "++
796 " hsc_enum ("++t++", "++f++", " ++
797 "printf (\"%s\", \""++hsName++"\"), "++
802 outFlagH :: Flag -> String
803 outFlagH (Include f) = "#include "++f++"\n"
804 outFlagH (Define n Nothing) = "#define "++n++" 1\n"
805 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
808 outTokenH :: (SourcePos, String, String) -> String
809 outTokenH (pos, key, arg) =
811 "include" -> outCLine pos++"#include "++arg++"\n"
812 "define" -> outCLine pos++"#define " ++arg++"\n"
813 "undef" -> outCLine pos++"#undef " ++arg++"\n"
814 "def" -> outCLine pos++case arg of
815 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
816 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
817 'i':'n':'l':'i':'n':'e':' ':_ ->
818 "#ifdef __GNUC__\n" ++
822 _ -> "extern "++header++";\n"
823 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
824 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
827 outTokenC :: (SourcePos, String, String) -> String
828 outTokenC (pos, key, arg) =
831 's':'t':'r':'u':'c':'t':' ':_ -> ""
832 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
833 'i':'n':'l':'i':'n':'e':' ':arg' ->
834 case span (\c -> c /= '{' && c /= '=') arg' of
837 "#ifndef __GNUC__\n" ++
841 "\n#ifndef __GNUC__\n" ++
846 _ -> outCLine pos++arg++"\n"
847 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
850 conditional :: String -> Bool
851 conditional "if" = True
852 conditional "ifdef" = True
853 conditional "ifndef" = True
854 conditional "elif" = True
855 conditional "else" = True
856 conditional "endif" = True
857 conditional "error" = True
858 conditional "warning" = True
859 conditional _ = False
861 outCLine :: SourcePos -> String
862 outCLine (SourcePos name line) =
863 "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
865 outHsLine :: SourcePos -> String
866 outHsLine (SourcePos name line) =
867 " hsc_line ("++show (line + 1)++", \""++
868 showCString name++"\");\n"
870 showCString :: String -> String
871 showCString = concatMap showCChar
873 showCChar '\"' = "\\\""
874 showCChar '\'' = "\\\'"
875 showCChar '?' = "\\?"
876 showCChar '\\' = "\\\\"
877 showCChar c | c >= ' ' && c <= '~' = [c]
878 showCChar '\a' = "\\a"
879 showCChar '\b' = "\\b"
880 showCChar '\f' = "\\f"
881 showCChar '\n' = "\\n\"\n \""
882 showCChar '\r' = "\\r"
883 showCChar '\t' = "\\t"
884 showCChar '\v' = "\\v"
886 intToDigit (ord c `quot` 64),
887 intToDigit (ord c `quot` 8 `mod` 8),
888 intToDigit (ord c `mod` 8)]
892 -----------------------------------------
893 -- Modified version from ghc/compiler/SysTools
894 -- Convert paths foo/baz to foo\baz on Windows
896 subst :: Char -> Char -> String -> String
897 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
898 subst a b = map (\x -> if x == a then b else x)
903 dosifyPath :: String -> String
904 dosifyPath = subst '/' '\\'
906 -- (getExecDir cmd) returns the directory in which the current
907 -- executable, which should be called 'cmd', is running
908 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
909 -- you'll get "/a/b/c" back as the result
910 getExecDir :: String -> IO (Maybe String)
912 getExecPath >>= maybe (return Nothing) removeCmdSuffix
913 where unDosifyPath = subst '\\' '/'
914 initN n = reverse . drop n . reverse
915 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
917 getExecPath :: IO (Maybe String)
918 #if defined(__HUGS__)
919 getExecPath = liftM Just getProgName
920 #elif defined(mingw32_HOST_OS)
922 allocaArray len $ \buf -> do
923 ret <- getModuleFileName nullPtr buf len
924 if ret == 0 then return Nothing
925 else liftM Just $ peekCString buf
926 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
928 foreign import stdcall unsafe "GetModuleFileNameA"
929 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
931 getExecPath = return Nothing