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)
46 import Compat.RawSystem ( rawSystem )
48 import System.Cmd ( rawSystem )
50 #define HAVE_rawSystem
52 import System.Cmd ( rawSystem )
53 #define HAVE_rawSystem
56 #if !defined(HAVE_runProcess) || !defined(HAVE_rawSystem)
58 #if __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600
59 import System.Cmd ( system )
61 import System ( system )
66 version = "hsc2hs version 0.66\n"
78 | Define String (Maybe String)
82 template_flag :: Flag -> Bool
83 template_flag (Template _) = True
84 template_flag _ = False
86 include :: String -> Flag
87 include s@('\"':_) = Include s
88 include s@('<' :_) = Include s
89 include s = Include ("\""++s++"\"")
91 define :: String -> Flag
92 define s = case break (== '=') s of
93 (name, []) -> Define name Nothing
94 (name, _:value) -> Define name (Just value)
96 options :: [OptDescr Flag]
98 Option ['o'] ["output"] (ReqArg Output "FILE")
99 "name of main output file",
100 Option ['t'] ["template"] (ReqArg Template "FILE")
102 Option ['c'] ["cc"] (ReqArg Compiler "PROG")
104 Option ['l'] ["ld"] (ReqArg Linker "PROG")
106 Option ['C'] ["cflag"] (ReqArg CompFlag "FLAG")
107 "flag to pass to the C compiler",
108 Option ['I'] [] (ReqArg (CompFlag . ("-I"++)) "DIR")
109 "passed to the C compiler",
110 Option ['L'] ["lflag"] (ReqArg LinkFlag "FLAG")
111 "flag to pass to the linker",
112 Option ['i'] ["include"] (ReqArg include "FILE")
113 "as if placed in the source",
114 Option ['D'] ["define"] (ReqArg define "NAME[=VALUE]")
115 "as if placed in the source",
116 Option [] ["no-compile"] (NoArg NoCompile)
117 "stop after writing *_hsc_make.c",
118 Option ['v'] ["verbose"] (NoArg Verbose)
119 "dump commands to stderr",
120 Option ['?'] ["help"] (NoArg Help)
121 "display this help and exit",
122 Option ['V'] ["version"] (NoArg Version)
123 "output version information and exit" ]
127 prog <- getProgramName
128 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
130 let (flags, files, errs) = getOpt Permute options args
132 -- If there is no Template flag explicitly specified, try
133 -- to find one by looking near the executable. This only
134 -- works on Win32 or Hugs (getExecDir). On Unix, there's a wrapper
135 -- script which specifies an explicit template flag.
136 flags_w_tpl <- if any template_flag flags then
139 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
551 -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
552 -- Returns a native-format path
554 mb <- getExecDir "bin/hsc2hs.exe"
556 Nothing -> return def
558 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
559 flg <- doesFileExist ghc_path
564 -- On a Win32 installation we execute the hsc2hs binary directly,
565 -- with no --cc flags, so we'll call locateGhc here, which will
566 -- succeed, via getExecDir.
568 -- On a Unix installation, we'll run the wrapper script hsc2hs.sh
569 -- (called plain hsc2hs in the installed tree), which will pass
570 -- a suitable C compiler via --cc
572 -- The in-place installation always uses the wrapper script,
573 -- (called hsc2hs-inplace, generated from hsc2hs.sh)
574 compiler <- case [c | Compiler c <- flags] of
575 [] -> locateGhc "ghc"
577 _ -> onlyOne "compiler"
579 linker <- case [l | Linker l <- flags] of
580 [] -> locateGhc compiler
582 _ -> onlyOne "linker"
584 writeFile cProgName $
585 concatMap outFlagHeaderCProg flags++
586 concatMap outHeaderCProg specials++
587 "\nint main (int argc, char *argv [])\n{\n"++
588 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
589 outHsLine (SourcePos name 0)++
590 concatMap outTokenHs toks++
593 -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
594 -- so we use something slightly more complicated. :-P
595 when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
598 rawSystemL ("compiling " ++ cProgName) beVerbose compiler
600 ++ [f | CompFlag f <- flags]
604 finallyRemove cProgName $ do
606 rawSystemL ("linking " ++ oProgName) beVerbose linker
607 ( [f | LinkFlag f <- flags]
611 finallyRemove oProgName $ do
613 rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
614 finallyRemove progName $ do
616 when needsH $ writeFile outHName $
617 "#ifndef "++includeGuard++"\n" ++
618 "#define "++includeGuard++"\n" ++
619 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
620 "#include <Rts.h>\n" ++
622 "#include <HsFFI.h>\n" ++
625 "#define HsChar int\n" ++
627 concatMap outFlagH flags++
628 concatMap outTokenH specials++
631 when needsC $ writeFile outCName $
632 "#include \""++outHFile++"\"\n"++
633 concatMap outTokenC specials
634 -- NB. outHFile not outHName; works better when processed
635 -- by gcc or mkdependC.
637 rawSystemL :: String -> Bool -> FilePath -> [String] -> IO ()
638 rawSystemL action flg prog args = do
639 let cmdLine = prog++" "++unwords args
640 when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
641 #ifndef HAVE_rawSystem
642 exitStatus <- system cmdLine
644 exitStatus <- rawSystem prog args
647 ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
650 rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
651 rawSystemWithStdOutL action flg prog args outFile = do
652 let cmdLine = prog++" "++unwords args++" >"++outFile
653 when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
654 #ifndef HAVE_runProcess
655 exitStatus <- system cmdLine
657 hOut <- openFile outFile WriteMode
658 process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
659 exitStatus <- waitForProcess process
663 ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
667 -- delay the cleanup of generated files until the end; attempts to
668 -- get around intermittent failure to delete files which has
669 -- just been exec'ed by a sub-process (Win32 only.)
670 finallyRemove :: FilePath -> IO a -> IO a
671 finallyRemove fp act =
673 (const $ noisyRemove fp)
677 catch (removeFile fpath)
678 (\ e -> hPutStrLn stderr ("Failed to remove file " ++ fpath ++ "; error= " ++ show e))
679 onlyOne :: String -> IO a
680 onlyOne what = die ("Only one "++what++" may be specified\n")
682 outFlagHeaderCProg :: Flag -> String
683 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
684 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
685 outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n"
686 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
687 outFlagHeaderCProg _ = ""
689 outHeaderCProg :: (SourcePos, String, String) -> String
690 outHeaderCProg (pos, key, arg) = case key of
691 "include" -> outCLine pos++"#include "++arg++"\n"
692 "define" -> outCLine pos++"#define "++arg++"\n"
693 "undef" -> outCLine pos++"#undef "++arg++"\n"
695 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
696 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
698 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
699 "let" -> case break (== '=') arg of
701 (header, _:body) -> case break isSpace header of
704 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
705 "printf ("++joinLines body++");\n"
708 joinLines = concat . intersperse " \\\n" . lines
710 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
711 outHeaderHs flags inH toks =
713 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
714 " printf (\"{-# OPTIONS -optc-D" ++
715 "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
716 "__GLASGOW_HASKELL__);\n" ++
719 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
720 Just f -> outInclude ("\""++f++"\"")
722 outFlag (Include f) = outInclude f
723 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
724 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
726 outSpecial (pos, key, arg) = case key of
727 "include" -> outInclude arg
728 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
730 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
732 goodForOptD arg = case arg of
734 c:_ | isSpace c -> True
737 toOptD arg = case break isSpace arg of
739 (name, _:value) -> name++'=':dropWhile isSpace value
741 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
742 " printf (\"{-# OPTIONS %s #-}\\n\", \""++
743 showCString s++"\");\n"++
745 " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
746 showCString s++"\");\n"++
749 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
750 " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++
751 showCString s++"\");\n"++
753 " printf (\"{-# INCLUDE %s #-}\\n\", \""++
754 showCString s++"\");\n"++
757 outTokenHs :: Token -> String
758 outTokenHs (Text pos txt) =
759 case break (== '\n') txt of
760 (allTxt, []) -> outText allTxt
762 outText (first++"\n")++
766 outText s = " fputs (\""++showCString s++"\", stdout);\n"
767 outTokenHs (Special pos key arg) =
773 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
775 "enum" -> outCLine pos++outEnum arg
776 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
778 outEnum :: String -> String
780 case break (== ',') arg of
782 (t, _:afterT) -> case break (== ',') afterT of
785 enums (_:s) = case break (== ',') s of
787 this = case break (== '=') $ dropWhile isSpace enum of
789 " hsc_enum ("++t++", "++f++", " ++
790 "hsc_haskellize (\""++name++"\"), "++
793 " hsc_enum ("++t++", "++f++", " ++
794 "printf (\"%s\", \""++hsName++"\"), "++
799 outFlagH :: Flag -> String
800 outFlagH (Include f) = "#include "++f++"\n"
801 outFlagH (Define n Nothing) = "#define "++n++" 1\n"
802 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
805 outTokenH :: (SourcePos, String, String) -> String
806 outTokenH (pos, key, arg) =
808 "include" -> outCLine pos++"#include "++arg++"\n"
809 "define" -> outCLine pos++"#define " ++arg++"\n"
810 "undef" -> outCLine pos++"#undef " ++arg++"\n"
811 "def" -> outCLine pos++case arg of
812 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
813 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
814 'i':'n':'l':'i':'n':'e':' ':_ ->
815 "#ifdef __GNUC__\n" ++
819 _ -> "extern "++header++";\n"
820 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
821 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
824 outTokenC :: (SourcePos, String, String) -> String
825 outTokenC (pos, key, arg) =
828 's':'t':'r':'u':'c':'t':' ':_ -> ""
829 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
830 'i':'n':'l':'i':'n':'e':' ':arg' ->
831 case span (\c -> c /= '{' && c /= '=') arg' of
834 "#ifndef __GNUC__\n" ++
838 "\n#ifndef __GNUC__\n" ++
843 _ -> outCLine pos++arg++"\n"
844 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
847 conditional :: String -> Bool
848 conditional "if" = True
849 conditional "ifdef" = True
850 conditional "ifndef" = True
851 conditional "elif" = True
852 conditional "else" = True
853 conditional "endif" = True
854 conditional "error" = True
855 conditional "warning" = True
856 conditional _ = False
858 outCLine :: SourcePos -> String
859 outCLine (SourcePos name line) =
860 "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
862 outHsLine :: SourcePos -> String
863 outHsLine (SourcePos name line) =
864 " hsc_line ("++show (line + 1)++", \""++
865 showCString name++"\");\n"
867 showCString :: String -> String
868 showCString = concatMap showCChar
870 showCChar '\"' = "\\\""
871 showCChar '\'' = "\\\'"
872 showCChar '?' = "\\?"
873 showCChar '\\' = "\\\\"
874 showCChar c | c >= ' ' && c <= '~' = [c]
875 showCChar '\a' = "\\a"
876 showCChar '\b' = "\\b"
877 showCChar '\f' = "\\f"
878 showCChar '\n' = "\\n\"\n \""
879 showCChar '\r' = "\\r"
880 showCChar '\t' = "\\t"
881 showCChar '\v' = "\\v"
883 intToDigit (ord c `quot` 64),
884 intToDigit (ord c `quot` 8 `mod` 8),
885 intToDigit (ord c `mod` 8)]
887 -----------------------------------------
888 -- Modified version from ghc/compiler/SysTools
889 -- Convert paths foo/baz to foo\baz on Windows
891 subst :: Char -> Char -> String -> String
892 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
893 subst a b = map (\x -> if x == a then b else x)
898 dosifyPath :: String -> String
899 dosifyPath = subst '/' '\\'
901 -- (getExecDir cmd) returns the directory in which the current
902 -- executable, which should be called 'cmd', is running
903 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
904 -- you'll get "/a/b/c" back as the result
905 getExecDir :: String -> IO (Maybe String)
907 getExecPath >>= maybe (return Nothing) removeCmdSuffix
908 where unDosifyPath = subst '\\' '/'
909 initN n = reverse . drop n . reverse
910 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
912 getExecPath :: IO (Maybe String)
913 #if defined(mingw32_HOST_OS)
915 allocaArray len $ \buf -> do
916 ret <- getModuleFileName nullPtr buf len
917 if ret == 0 then return Nothing
918 else liftM Just $ peekCString buf
919 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
921 foreign import stdcall unsafe "GetModuleFileNameA"
922 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
924 getExecPath = return Nothing