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
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
47 #elif __HUGS__ || __NHC__ >= 117
48 import System.Cmd ( rawSystem )
49 #define HAVE_rawSystem
52 #if !defined(HAVE_runProcess) || !defined(HAVE_rawSystem)
54 #if __HUGS__ || __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
136 do mb_path <- getExecDir "/Main.hs"
138 do mb_path <- getExecDir "/bin/hsc2hs.exe"
144 let templ = path ++ "/template-hsc.h"
145 flg <- doesFileExist templ
147 then return ((Template templ):)
149 return (add_opt flags)
150 case (files, errs) of
152 | any isHelp flags_w_tpl -> bye (usageInfo header options)
153 | any isVersion flags_w_tpl -> bye version
155 isHelp Help = True; isHelp _ = False
156 isVersion Version = True; isVersion _ = False
157 ((_:_), []) -> mapM_ (processFile flags_w_tpl) files
158 (_, _ ) -> die (concat errs ++ usageInfo header options)
160 getProgramName :: IO String
161 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
162 where str `withoutSuffix` suff
163 | suff `isSuffixOf` str = take (length str - length suff) str
166 bye :: String -> IO a
167 bye s = putStr s >> exitWith ExitSuccess
169 die :: String -> IO a
170 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
172 processFile :: [Flag] -> String -> IO ()
173 processFile flags name
174 = do let file_name = dosifyPath name
175 s <- readFile file_name
177 Parser p -> case p (SourcePos file_name 1) s of
178 Success _ _ _ toks -> output flags file_name toks
179 Failure (SourcePos name' line) msg ->
180 die (name'++":"++show line++": "++msg++"\n")
182 ------------------------------------------------------------------------
183 -- A deterministic parser which remembers the text which has been parsed.
185 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
187 data ParseResult a = Success !SourcePos String String a
188 | Failure !SourcePos String
190 data SourcePos = SourcePos String !Int
192 updatePos :: SourcePos -> Char -> SourcePos
193 updatePos pos@(SourcePos name line) ch = case ch of
194 '\n' -> SourcePos name (line + 1)
197 instance Monad Parser where
198 return a = Parser $ \pos s -> Success pos [] s a
200 Parser $ \pos s -> case m pos s of
201 Success pos' out1 s' a -> case k a of
202 Parser k' -> case k' pos' s' of
203 Success pos'' out2 imp'' b ->
204 Success pos'' (out1++out2) imp'' b
205 Failure pos'' msg -> Failure pos'' msg
206 Failure pos' msg -> Failure pos' msg
207 fail msg = Parser $ \pos _ -> Failure pos msg
209 instance MonadPlus Parser where
211 Parser m `mplus` Parser n =
212 Parser $ \pos s -> case m pos s of
213 success@(Success _ _ _ _) -> success
214 Failure _ _ -> n pos s
216 getPos :: Parser SourcePos
217 getPos = Parser $ \pos s -> Success pos [] s pos
219 setPos :: SourcePos -> Parser ()
220 setPos pos = Parser $ \_ s -> Success pos [] s ()
222 message :: Parser a -> String -> Parser a
223 Parser m `message` msg =
224 Parser $ \pos s -> case m pos s of
225 success@(Success _ _ _ _) -> success
226 Failure pos' _ -> Failure pos' msg
228 catchOutput_ :: Parser a -> Parser String
229 catchOutput_ (Parser m) =
230 Parser $ \pos s -> case m pos s of
231 Success pos' out s' _ -> Success pos' [] s' out
232 Failure pos' msg -> Failure pos' msg
234 fakeOutput :: Parser a -> String -> Parser a
235 Parser m `fakeOutput` out =
236 Parser $ \pos s -> case m pos s of
237 Success pos' _ s' a -> Success pos' out s' a
238 Failure pos' msg -> Failure pos' msg
240 lookAhead :: Parser String
241 lookAhead = Parser $ \pos s -> Success pos [] s s
243 satisfy :: (Char -> Bool) -> Parser Char
245 Parser $ \pos s -> case s of
246 c:cs | p c -> Success (updatePos pos c) [c] cs c
247 _ -> Failure pos "Bad character"
249 char_ :: Char -> Parser ()
251 satisfy (== c) `message` (show c++" expected")
254 anyChar_ :: Parser ()
256 satisfy (const True) `message` "Unexpected end of file"
259 any2Chars_ :: Parser ()
260 any2Chars_ = anyChar_ >> anyChar_
262 many :: Parser a -> Parser [a]
263 many p = many1 p `mplus` return []
265 many1 :: Parser a -> Parser [a]
266 many1 p = liftM2 (:) p (many p)
268 many_ :: Parser a -> Parser ()
269 many_ p = many1_ p `mplus` return ()
271 many1_ :: Parser a -> Parser ()
272 many1_ p = p >> many_ p
274 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
275 manySatisfy = many . satisfy
276 manySatisfy1 = many1 . satisfy
278 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
279 manySatisfy_ = many_ . satisfy
280 manySatisfy1_ = many1_ . satisfy
282 ------------------------------------------------------------------------
283 -- Parser of hsc syntax.
286 = Text SourcePos String
287 | Special SourcePos String String
289 parser :: Parser [Token]
292 t <- catchOutput_ text
296 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
297 return (if null t then rest else Text pos t : rest)
304 c:_ | isAlpha c || c == '_' -> do
306 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
308 c:_ | isHsSymbol c -> do
309 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
312 '-':'-':symb' | all (== '-') symb' -> do
313 return () `fakeOutput` symb
314 manySatisfy_ (/= '\n')
317 return () `fakeOutput` unescapeHashes symb
319 '\"':_ -> do anyChar_; hsString '\"'; text
320 '\'':_ -> do anyChar_; hsString '\''; text
321 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
322 _:_ -> do anyChar_; text
324 hsString :: Char -> Parser ()
329 c:_ | c == quote -> anyChar_
334 char_ '\\' `mplus` return ()
336 | otherwise -> do any2Chars_; hsString quote
337 _:_ -> do anyChar_; hsString quote
339 hsComment :: Parser ()
344 '-':'}':_ -> any2Chars_
345 '{':'-':_ -> do any2Chars_; hsComment; hsComment
346 _:_ -> do anyChar_; hsComment
348 linePragma :: Parser ()
352 satisfy (\c -> c == 'L' || c == 'l')
353 satisfy (\c -> c == 'I' || c == 'i')
354 satisfy (\c -> c == 'N' || c == 'n')
355 satisfy (\c -> c == 'E' || c == 'e')
356 manySatisfy1_ isSpace
357 line <- liftM read $ manySatisfy1 isDigit
358 manySatisfy1_ isSpace
360 name <- manySatisfy (/= '\"')
366 setPos (SourcePos name (line - 1))
368 isHsSymbol :: Char -> Bool
369 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
370 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
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
378 unescapeHashes :: String -> String
379 unescapeHashes [] = []
380 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
381 unescapeHashes (c:s) = c : unescapeHashes s
383 lookAheadC :: Parser String
384 lookAheadC = liftM joinLines lookAhead
387 joinLines ('\\':'\n':s) = joinLines s
388 joinLines (c:s) = c : joinLines s
390 satisfyC :: (Char -> Bool) -> Parser Char
394 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
397 charC_ :: Char -> Parser ()
399 satisfyC (== c) `message` (show c++" expected")
402 anyCharC_ :: Parser ()
404 satisfyC (const True) `message` "Unexpected end of file"
407 any2CharsC_ :: Parser ()
408 any2CharsC_ = anyCharC_ >> anyCharC_
410 manySatisfyC :: (Char -> Bool) -> Parser String
411 manySatisfyC = many . satisfyC
413 manySatisfyC_ :: (Char -> Bool) -> Parser ()
414 manySatisfyC_ = many_ . satisfyC
416 special :: Parser Token
418 manySatisfyC_ (\c -> isSpace c && c /= '\n')
423 manySatisfyC_ isSpace
424 sp <- keyArg (== '\n')
427 _ -> keyArg (const False)
429 keyArg :: (Char -> Bool) -> Parser Token
432 key <- keyword `message` "hsc keyword or '{' expected"
433 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
434 arg <- catchOutput_ (argument eol)
435 return (Special pos key arg)
437 keyword :: Parser String
439 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
440 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
443 argument :: (Char -> Bool) -> Parser ()
448 c:_ | eol c -> do anyCharC_; argument eol
450 '\"':_ -> do anyCharC_; cString '\"'; argument eol
451 '\'':_ -> do anyCharC_; cString '\''; argument eol
452 '(':_ -> do anyCharC_; nested ')'; argument eol
454 '/':'*':_ -> do any2CharsC_; cComment; argument eol
456 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
457 '[':_ -> do anyCharC_; nested ']'; argument eol
459 '{':_ -> do anyCharC_; nested '}'; argument eol
461 _:_ -> do anyCharC_; argument eol
463 nested :: Char -> Parser ()
464 nested c = do argument (== '\n'); charC_ c
466 cComment :: Parser ()
471 '*':'/':_ -> do any2CharsC_
472 _:_ -> do anyCharC_; cComment
474 cString :: Char -> Parser ()
479 c:_ | c == quote -> anyCharC_
480 '\\':_:_ -> do any2CharsC_; cString quote
481 _:_ -> do anyCharC_; cString quote
483 ------------------------------------------------------------------------
484 -- Write the output files.
486 splitName :: String -> (String, String)
488 case break (== '/') name of
489 (file, []) -> ([], file)
490 (dir, sep:rest) -> (dir++sep:restDir, restFile)
492 (restDir, restFile) = splitName rest
494 splitExt :: String -> (String, String)
496 case break (== '.') name of
497 (base, []) -> (base, [])
498 (base, sepRest@(sep:rest))
499 | null restExt -> (base, sepRest)
500 | otherwise -> (base++sep:restBase, restExt)
502 (restBase, restExt) = splitExt rest
504 output :: [Flag] -> String -> [Token] -> IO ()
505 output flags name toks = do
507 (outName, outDir, outBase) <- case [f | Output f <- flags] of
508 [] -> if not (null ext) && last ext == 'c'
509 then return (dir++base++init ext, dir, base)
512 then return (dir++base++"_out.hs", dir, base)
513 else return (dir++base++".hs", dir, base)
515 (dir, file) = splitName name
516 (base, ext) = splitExt file
518 (dir, file) = splitName f
519 (base, _) = splitExt file
520 in return (f, dir, base)
521 _ -> onlyOne "output file"
523 let cProgName = outDir++outBase++"_hsc_make.c"
524 oProgName = outDir++outBase++"_hsc_make.o"
525 progName = outDir++outBase++"_hsc_make"
526 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
527 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
528 -- via GHC has changed a few times, so this seems to be the only way... :-P * * *
531 outHFile = outBase++"_hsc.h"
532 outHName = outDir++outHFile
533 outCName = outDir++outBase++"_hsc.c"
535 beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
538 | null outDir = dosifyPath ("./" ++ progName)
539 | otherwise = progName
541 let specials = [(pos, key, arg) | Special pos key arg <- toks]
543 let needsC = any (\(_, key, _) -> key == "def") specials
546 let includeGuard = map fixChar outHName
548 fixChar c | isAlphaNum c = toUpper c
552 compiler <- case [c | Compiler c <- flags] of
555 _ -> onlyOne "compiler"
557 linker <- case [l | Linker l <- flags] of
558 [] -> return compiler
560 _ -> onlyOne "linker"
562 -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
563 -- Returns a native-format path
565 mb <- getExecDir "bin/hsc2hs.exe"
567 Nothing -> return def
569 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
570 flg <- doesFileExist ghc_path
575 -- On a Win32 installation we execute the hsc2hs binary directly,
576 -- with no --cc flags, so we'll call locateGhc here, which will
577 -- succeed, via getExecDir.
579 -- On a Unix installation, we'll run the wrapper script hsc2hs.sh
580 -- (called plain hsc2hs in the installed tree), which will pass
581 -- a suitable C compiler via --cc
583 -- The in-place installation always uses the wrapper script,
584 -- (called hsc2hs-inplace, generated from hsc2hs.sh)
585 compiler <- case [c | Compiler c <- flags] of
586 [] -> locateGhc "ghc"
588 _ -> onlyOne "compiler"
590 linker <- case [l | Linker l <- flags] of
591 [] -> locateGhc compiler
593 _ -> onlyOne "linker"
596 writeFile cProgName $
597 concatMap outFlagHeaderCProg flags++
598 concatMap outHeaderCProg specials++
599 "\nint main (int argc, char *argv [])\n{\n"++
600 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
601 outHsLine (SourcePos name 0)++
602 concatMap outTokenHs toks++
605 -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
606 -- so we use something slightly more complicated. :-P
607 when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
610 rawSystemL ("compiling " ++ cProgName) beVerbose compiler
612 ++ [f | CompFlag f <- flags]
618 rawSystemL ("linking " ++ oProgName) beVerbose linker
619 ( [f | LinkFlag f <- flags]
625 rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
628 when needsH $ writeFile outHName $
629 "#ifndef "++includeGuard++"\n" ++
630 "#define "++includeGuard++"\n" ++
631 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
632 "#include <Rts.h>\n" ++
634 "#include <HsFFI.h>\n" ++
637 "#define HsChar int\n" ++
639 concatMap outFlagH flags++
640 concatMap outTokenH specials++
643 when needsC $ writeFile outCName $
644 "#include \""++outHFile++"\"\n"++
645 concatMap outTokenC specials
646 -- NB. outHFile not outHName; works better when processed
647 -- by gcc or mkdependC.
649 rawSystemL :: String -> Bool -> FilePath -> [String] -> IO ()
650 rawSystemL action flg prog args = do
651 let cmdLine = prog++" "++unwords args
652 when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
653 #ifndef HAVE_rawSystem
654 exitStatus <- system cmdLine
656 exitStatus <- rawSystem prog args
659 ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
662 rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
663 rawSystemWithStdOutL action flg prog args outFile = do
664 let cmdLine = prog++" "++unwords args++" >"++outFile
665 when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
666 #ifndef HAVE_runProcess
667 exitStatus <- system cmdLine
669 hOut <- openFile outFile WriteMode
670 process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
671 exitStatus <- waitForProcess process
675 ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
678 onlyOne :: String -> IO a
679 onlyOne what = die ("Only one "++what++" may be specified\n")
681 outFlagHeaderCProg :: Flag -> String
682 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
683 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
684 outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n"
685 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
686 outFlagHeaderCProg _ = ""
688 outHeaderCProg :: (SourcePos, String, String) -> String
689 outHeaderCProg (pos, key, arg) = case key of
690 "include" -> outCLine pos++"#include "++arg++"\n"
691 "define" -> outCLine pos++"#define "++arg++"\n"
692 "undef" -> outCLine pos++"#undef "++arg++"\n"
694 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
695 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
697 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
698 "let" -> case break (== '=') arg of
700 (header, _:body) -> case break isSpace header of
703 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
704 "printf ("++joinLines body++");\n"
707 joinLines = concat . intersperse " \\\n" . lines
709 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
710 outHeaderHs flags inH toks =
712 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
713 " printf (\"{-# OPTIONS -optc-D" ++
714 "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
715 "__GLASGOW_HASKELL__);\n" ++
718 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
719 Just f -> outInclude ("\""++f++"\"")
721 outFlag (Include f) = outInclude f
722 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
723 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
725 outSpecial (pos, key, arg) = case key of
726 "include" -> outInclude arg
727 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
729 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
731 goodForOptD arg = case arg of
733 c:_ | isSpace c -> True
736 toOptD arg = case break isSpace arg of
738 (name, _:value) -> name++'=':dropWhile isSpace value
740 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
741 " printf (\"{-# OPTIONS %s #-}\\n\", \""++
742 showCString s++"\");\n"++
744 " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
745 showCString s++"\");\n"++
748 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
749 " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++
750 showCString s++"\");\n"++
752 " printf (\"{-# INCLUDE %s #-}\\n\", \""++
753 showCString s++"\");\n"++
756 outTokenHs :: Token -> String
757 outTokenHs (Text pos txt) =
758 case break (== '\n') txt of
759 (allTxt, []) -> outText allTxt
761 outText (first++"\n")++
765 outText s = " fputs (\""++showCString s++"\", stdout);\n"
766 outTokenHs (Special pos key arg) =
772 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
774 "enum" -> outCLine pos++outEnum arg
775 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
777 outEnum :: String -> String
779 case break (== ',') arg of
781 (t, _:afterT) -> case break (== ',') afterT of
784 enums (_:s) = case break (== ',') s of
786 this = case break (== '=') $ dropWhile isSpace enum of
788 " hsc_enum ("++t++", "++f++", " ++
789 "hsc_haskellize (\""++name++"\"), "++
792 " hsc_enum ("++t++", "++f++", " ++
793 "printf (\"%s\", \""++hsName++"\"), "++
798 outFlagH :: Flag -> String
799 outFlagH (Include f) = "#include "++f++"\n"
800 outFlagH (Define n Nothing) = "#define "++n++" 1\n"
801 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
804 outTokenH :: (SourcePos, String, String) -> String
805 outTokenH (pos, key, arg) =
807 "include" -> outCLine pos++"#include "++arg++"\n"
808 "define" -> outCLine pos++"#define " ++arg++"\n"
809 "undef" -> outCLine pos++"#undef " ++arg++"\n"
810 "def" -> outCLine pos++case arg of
811 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
812 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
813 'i':'n':'l':'i':'n':'e':' ':_ ->
814 "#ifdef __GNUC__\n" ++
818 _ -> "extern "++header++";\n"
819 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
820 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
823 outTokenC :: (SourcePos, String, String) -> String
824 outTokenC (pos, key, arg) =
827 's':'t':'r':'u':'c':'t':' ':_ -> ""
828 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
829 'i':'n':'l':'i':'n':'e':' ':arg' ->
830 case span (\c -> c /= '{' && c /= '=') arg' of
833 "#ifndef __GNUC__\n" ++
837 "\n#ifndef __GNUC__\n" ++
842 _ -> outCLine pos++arg++"\n"
843 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
846 conditional :: String -> Bool
847 conditional "if" = True
848 conditional "ifdef" = True
849 conditional "ifndef" = True
850 conditional "elif" = True
851 conditional "else" = True
852 conditional "endif" = True
853 conditional "error" = True
854 conditional "warning" = True
855 conditional _ = False
857 outCLine :: SourcePos -> String
858 outCLine (SourcePos name line) =
859 "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
861 outHsLine :: SourcePos -> String
862 outHsLine (SourcePos name line) =
863 " hsc_line ("++show (line + 1)++", \""++
864 showCString name++"\");\n"
866 showCString :: String -> String
867 showCString = concatMap showCChar
869 showCChar '\"' = "\\\""
870 showCChar '\'' = "\\\'"
871 showCChar '?' = "\\?"
872 showCChar '\\' = "\\\\"
873 showCChar c | c >= ' ' && c <= '~' = [c]
874 showCChar '\a' = "\\a"
875 showCChar '\b' = "\\b"
876 showCChar '\f' = "\\f"
877 showCChar '\n' = "\\n\"\n \""
878 showCChar '\r' = "\\r"
879 showCChar '\t' = "\\t"
880 showCChar '\v' = "\\v"
882 intToDigit (ord c `quot` 64),
883 intToDigit (ord c `quot` 8 `mod` 8),
884 intToDigit (ord c `mod` 8)]
886 -----------------------------------------
887 -- Modified version from ghc/compiler/SysTools
888 -- Convert paths foo/baz to foo\baz on Windows
890 subst :: Char -> Char -> String -> String
891 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
892 subst a b = map (\x -> if x == a then b else x)
897 dosifyPath :: String -> String
898 dosifyPath = subst '/' '\\'
900 -- (getExecDir cmd) returns the directory in which the current
901 -- executable, which should be called 'cmd', is running
902 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
903 -- you'll get "/a/b/c" back as the result
904 getExecDir :: String -> IO (Maybe String)
906 getExecPath >>= maybe (return Nothing) removeCmdSuffix
907 where unDosifyPath = subst '\\' '/'
908 initN n = reverse . drop n . reverse
909 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
911 getExecPath :: IO (Maybe String)
912 #if defined(__HUGS__)
913 getExecPath = liftM Just getProgName
914 #elif defined(mingw32_HOST_OS)
916 allocaArray len $ \buf -> do
917 ret <- getModuleFileName nullPtr buf len
918 if ret == 0 then return Nothing
919 else liftM Just $ peekCString buf
920 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
922 foreign import stdcall unsafe "GetModuleFileNameA"
923 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
925 getExecPath = return Nothing