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, bracket_)
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]
600 finallyRemove cProgName $ do
602 rawSystemL ("linking " ++ oProgName) beVerbose linker
603 ( [f | LinkFlag f <- flags]
607 finallyRemove oProgName $ do
609 rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
610 finallyRemove progName $ do
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"
663 -- delay the cleanup of generated files until the end; attempts to
664 -- get around intermittent failure to delete files which has
665 -- just been exec'ed by a sub-process (Win32 only.)
666 finallyRemove :: FilePath -> IO a -> IO a
667 finallyRemove fp act =
669 (const $ noisyRemove fp)
673 catch (removeFile fpath)
674 (\ e -> hPutStrLn stderr ("Failed to remove file " ++ fpath ++ "; error= " ++ show e))
675 onlyOne :: String -> IO a
676 onlyOne what = die ("Only one "++what++" may be specified\n")
678 outFlagHeaderCProg :: Flag -> String
679 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
680 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
681 outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n"
682 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
683 outFlagHeaderCProg _ = ""
685 outHeaderCProg :: (SourcePos, String, String) -> String
686 outHeaderCProg (pos, key, arg) = case key of
687 "include" -> outCLine pos++"#include "++arg++"\n"
688 "define" -> outCLine pos++"#define "++arg++"\n"
689 "undef" -> outCLine pos++"#undef "++arg++"\n"
691 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
692 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
694 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
695 "let" -> case break (== '=') arg of
697 (header, _:body) -> case break isSpace header of
700 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
701 "printf ("++joinLines body++");\n"
704 joinLines = concat . intersperse " \\\n" . lines
706 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
707 outHeaderHs flags inH toks =
709 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
710 " printf (\"{-# OPTIONS -optc-D" ++
711 "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
712 "__GLASGOW_HASKELL__);\n" ++
715 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
716 Just f -> outInclude ("\""++f++"\"")
718 outFlag (Include f) = outInclude f
719 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
720 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
722 outSpecial (pos, key, arg) = case key of
723 "include" -> outInclude arg
724 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
726 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
728 goodForOptD arg = case arg of
730 c:_ | isSpace c -> True
733 toOptD arg = case break isSpace arg of
735 (name, _:value) -> name++'=':dropWhile isSpace value
737 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
738 " printf (\"{-# OPTIONS %s #-}\\n\", \""++
739 showCString s++"\");\n"++
741 " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
742 showCString s++"\");\n"++
745 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
746 " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++
747 showCString s++"\");\n"++
749 " printf (\"{-# INCLUDE %s #-}\\n\", \""++
750 showCString s++"\");\n"++
753 outTokenHs :: Token -> String
754 outTokenHs (Text pos txt) =
755 case break (== '\n') txt of
756 (allTxt, []) -> outText allTxt
758 outText (first++"\n")++
762 outText s = " fputs (\""++showCString s++"\", stdout);\n"
763 outTokenHs (Special pos key arg) =
769 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
771 "enum" -> outCLine pos++outEnum arg
772 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
774 outEnum :: String -> String
776 case break (== ',') arg of
778 (t, _:afterT) -> case break (== ',') afterT of
781 enums (_:s) = case break (== ',') s of
783 this = case break (== '=') $ dropWhile isSpace enum of
785 " hsc_enum ("++t++", "++f++", " ++
786 "hsc_haskellize (\""++name++"\"), "++
789 " hsc_enum ("++t++", "++f++", " ++
790 "printf (\"%s\", \""++hsName++"\"), "++
795 outFlagH :: Flag -> String
796 outFlagH (Include f) = "#include "++f++"\n"
797 outFlagH (Define n Nothing) = "#define "++n++" 1\n"
798 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
801 outTokenH :: (SourcePos, String, String) -> String
802 outTokenH (pos, key, arg) =
804 "include" -> outCLine pos++"#include "++arg++"\n"
805 "define" -> outCLine pos++"#define " ++arg++"\n"
806 "undef" -> outCLine pos++"#undef " ++arg++"\n"
807 "def" -> outCLine pos++case arg of
808 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
809 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
810 'i':'n':'l':'i':'n':'e':' ':_ ->
811 "#ifdef __GNUC__\n" ++
815 _ -> "extern "++header++";\n"
816 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
817 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
820 outTokenC :: (SourcePos, String, String) -> String
821 outTokenC (pos, key, arg) =
824 's':'t':'r':'u':'c':'t':' ':_ -> ""
825 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
826 'i':'n':'l':'i':'n':'e':' ':arg' ->
827 case span (\c -> c /= '{' && c /= '=') arg' of
830 "#ifndef __GNUC__\n" ++
834 "\n#ifndef __GNUC__\n" ++
839 _ -> outCLine pos++arg++"\n"
840 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
843 conditional :: String -> Bool
844 conditional "if" = True
845 conditional "ifdef" = True
846 conditional "ifndef" = True
847 conditional "elif" = True
848 conditional "else" = True
849 conditional "endif" = True
850 conditional "error" = True
851 conditional "warning" = True
852 conditional _ = False
854 outCLine :: SourcePos -> String
855 outCLine (SourcePos name line) =
856 "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
858 outHsLine :: SourcePos -> String
859 outHsLine (SourcePos name line) =
860 " hsc_line ("++show (line + 1)++", \""++
861 showCString name++"\");\n"
863 showCString :: String -> String
864 showCString = concatMap showCChar
866 showCChar '\"' = "\\\""
867 showCChar '\'' = "\\\'"
868 showCChar '?' = "\\?"
869 showCChar '\\' = "\\\\"
870 showCChar c | c >= ' ' && c <= '~' = [c]
871 showCChar '\a' = "\\a"
872 showCChar '\b' = "\\b"
873 showCChar '\f' = "\\f"
874 showCChar '\n' = "\\n\"\n \""
875 showCChar '\r' = "\\r"
876 showCChar '\t' = "\\t"
877 showCChar '\v' = "\\v"
879 intToDigit (ord c `quot` 64),
880 intToDigit (ord c `quot` 8 `mod` 8),
881 intToDigit (ord c `mod` 8)]
883 -----------------------------------------
884 -- Modified version from ghc/compiler/SysTools
885 -- Convert paths foo/baz to foo\baz on Windows
887 subst :: Char -> Char -> String -> String
888 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
889 subst a b = map (\x -> if x == a then b else x)
894 dosifyPath :: String -> String
895 dosifyPath = subst '/' '\\'
897 -- (getExecDir cmd) returns the directory in which the current
898 -- executable, which should be called 'cmd', is running
899 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
900 -- you'll get "/a/b/c" back as the result
901 getExecDir :: String -> IO (Maybe String)
903 getExecPath >>= maybe (return Nothing) removeCmdSuffix
904 where unDosifyPath = subst '\\' '/'
905 initN n = reverse . drop n . reverse
906 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
908 getExecPath :: IO (Maybe String)
909 #if defined(mingw32_HOST_OS)
911 allocaArray len $ \buf -> do
912 ret <- getModuleFileName nullPtr buf len
913 if ret == 0 then return Nothing
914 else liftM Just $ peekCString buf
915 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
917 foreign import stdcall unsafe "GetModuleFileNameA"
918 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
920 getExecPath = return Nothing