2 {-# LANGUAGE CPP, ForeignFunctionInterface #-}
4 ------------------------------------------------------------------------
5 -- Program for converting .hsc files to .hs files, by converting the
6 -- file into a C program which is run to generate the Haskell source.
7 -- Certain items known only to the C compiler can then be used in
8 -- the Haskell module; for example #defined constants, byte offsets
9 -- within structures, etc.
11 -- See the documentation in the Users' Guide for more details.
13 #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
14 #include "../../includes/ghcconfig.h"
17 import Control.Monad ( MonadPlus(..), liftM, liftM2, when )
18 import Data.Char ( isAlpha, isAlphaNum, isSpace, isDigit,
19 toUpper, intToDigit, ord )
20 import Data.List ( intersperse, isSuffixOf )
21 import System.Cmd ( system, rawSystem )
22 import System.Console.GetOpt
24 #if defined(mingw32_HOST_OS)
26 import Foreign.C.String
28 import System.Directory ( removeFile, doesFileExist, findExecutable )
29 import System.Environment ( getProgName, getArgs )
30 import System.Exit ( ExitCode(..), exitWith )
31 import System.IO ( hPutStr, hPutStrLn, stderr )
33 #if __GLASGOW_HASKELL__ >= 604
34 import System.Process ( runProcess, waitForProcess )
35 import System.IO ( openFile, IOMode(..), hClose )
36 #define HAVE_runProcess
39 import IO ( bracket_ )
40 import Distribution.Text
43 import Paths_hsc2hs ( getDataFileName, version )
44 import Data.Version ( showVersion )
46 import System.Directory ( getCurrentDirectory )
47 getDataFileName s = do here <- getCurrentDirectory
49 version = "0.67" -- TODO!!!
53 #ifdef __GLASGOW_HASKELL__
54 default_compiler = "ghc"
56 default_compiler = "gcc"
59 versionString :: String
60 versionString = "hsc2hs version " ++ showVersion version ++ "\n"
72 | Define String (Maybe String)
76 template_flag :: Flag -> Bool
77 template_flag (Template _) = True
78 template_flag _ = False
80 include :: String -> Flag
81 include s@('\"':_) = Include s
82 include s@('<' :_) = Include s
83 include s = Include ("\""++s++"\"")
85 define :: String -> Flag
86 define s = case break (== '=') s of
87 (name, []) -> Define name Nothing
88 (name, _:value) -> Define name (Just value)
90 options :: [OptDescr Flag]
92 Option ['o'] ["output"] (ReqArg Output "FILE")
93 "name of main output file",
94 Option ['t'] ["template"] (ReqArg Template "FILE")
96 Option ['c'] ["cc"] (ReqArg Compiler "PROG")
98 Option ['l'] ["ld"] (ReqArg Linker "PROG")
100 Option ['C'] ["cflag"] (ReqArg CompFlag "FLAG")
101 "flag to pass to the C compiler",
102 Option ['I'] [] (ReqArg (CompFlag . ("-I"++)) "DIR")
103 "passed to the C compiler",
104 Option ['L'] ["lflag"] (ReqArg LinkFlag "FLAG")
105 "flag to pass to the linker",
106 Option ['i'] ["include"] (ReqArg include "FILE")
107 "as if placed in the source",
108 Option ['D'] ["define"] (ReqArg define "NAME[=VALUE]")
109 "as if placed in the source",
110 Option [] ["no-compile"] (NoArg NoCompile)
111 "stop after writing *_hsc_make.c",
112 Option ['v'] ["verbose"] (NoArg Verbose)
113 "dump commands to stderr",
114 Option ['?'] ["help"] (NoArg Help)
115 "display this help and exit",
116 Option ['V'] ["version"] (NoArg Version)
117 "output version information and exit" ]
121 prog <- getProgramName
122 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
124 let (flags, files, errs) = getOpt Permute options args
126 -- If there is no Template flag explicitly specified, try
127 -- to find one. We first look near the executable. This only
128 -- works on Win32 or Hugs (getExecDir). If this finds a template
129 -- file then it's certainly the one we want, even if hsc2hs isn't
130 -- installed where we told Cabal it would be installed.
132 -- Next we try the location we told Cabal about.
134 -- If neither of the above work, then hopefully we're on Unix and
135 -- there's a wrapper script which specifies an explicit template flag.
137 if any template_flag flags then return flags
138 else do mb_path <- getExecDir "/bin/hsc2hs.exe"
141 Nothing -> return Nothing
143 -- Euch, this is horrible. Unfortunately
144 -- Paths_hsc2hs isn't too useful for a
145 -- relocatable binary, though.
146 let templ1 = path ++ "/hsc2hs-" ++ display Paths_hsc2hs.version ++ "/template-hsc.h"
147 exists1 <- doesFileExist templ1
149 then return (Just templ1)
152 Just templ1 -> return (Template templ1 : flags)
154 templ2 <- getDataFileName "template-hsc.h"
155 exists2 <- doesFileExist templ2
156 if exists2 then return (Template templ2 : flags)
159 -- take only the last --template flag on the cmd line
161 (before,tpl:after) = break template_flag (reverse flags_w_tpl0)
162 flags_w_tpl = reverse (before ++ tpl : filter (not.template_flag) after)
164 case (files, errs) of
166 | any isHelp flags_w_tpl -> bye (usageInfo header options)
167 | any isVersion flags_w_tpl -> bye versionString
169 isHelp Help = True; isHelp _ = False
170 isVersion Version = True; isVersion _ = False
171 ((_:_), []) -> mapM_ (processFile flags_w_tpl) files
172 (_, _ ) -> die (concat errs ++ usageInfo header options)
174 getProgramName :: IO String
175 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
176 where str `withoutSuffix` suff
177 | suff `isSuffixOf` str = take (length str - length suff) str
180 bye :: String -> IO a
181 bye s = putStr s >> exitWith ExitSuccess
183 die :: String -> IO a
184 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
186 processFile :: [Flag] -> String -> IO ()
187 processFile flags name
188 = do let file_name = dosifyPath name
189 s <- readFile file_name
191 Parser p -> case p (SourcePos file_name 1) s of
192 Success _ _ _ toks -> output flags file_name toks
193 Failure (SourcePos name' line) msg ->
194 die (name'++":"++show line++": "++msg++"\n")
196 ------------------------------------------------------------------------
197 -- A deterministic parser which remembers the text which has been parsed.
199 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
201 data ParseResult a = Success !SourcePos String String a
202 | Failure !SourcePos String
204 data SourcePos = SourcePos String !Int
206 updatePos :: SourcePos -> Char -> SourcePos
207 updatePos pos@(SourcePos name line) ch = case ch of
208 '\n' -> SourcePos name (line + 1)
211 instance Monad Parser where
212 return a = Parser $ \pos s -> Success pos [] s a
214 Parser $ \pos s -> case m pos s of
215 Success pos' out1 s' a -> case k a of
216 Parser k' -> case k' pos' s' of
217 Success pos'' out2 imp'' b ->
218 Success pos'' (out1++out2) imp'' b
219 Failure pos'' msg -> Failure pos'' msg
220 Failure pos' msg -> Failure pos' msg
221 fail msg = Parser $ \pos _ -> Failure pos msg
223 instance MonadPlus Parser where
225 Parser m `mplus` Parser n =
226 Parser $ \pos s -> case m pos s of
227 success@(Success _ _ _ _) -> success
228 Failure _ _ -> n pos s
230 getPos :: Parser SourcePos
231 getPos = Parser $ \pos s -> Success pos [] s pos
233 setPos :: SourcePos -> Parser ()
234 setPos pos = Parser $ \_ s -> Success pos [] s ()
236 message :: Parser a -> String -> Parser a
237 Parser m `message` msg =
238 Parser $ \pos s -> case m pos s of
239 success@(Success _ _ _ _) -> success
240 Failure pos' _ -> Failure pos' msg
242 catchOutput_ :: Parser a -> Parser String
243 catchOutput_ (Parser m) =
244 Parser $ \pos s -> case m pos s of
245 Success pos' out s' _ -> Success pos' [] s' out
246 Failure pos' msg -> Failure pos' msg
248 fakeOutput :: Parser a -> String -> Parser a
249 Parser m `fakeOutput` out =
250 Parser $ \pos s -> case m pos s of
251 Success pos' _ s' a -> Success pos' out s' a
252 Failure pos' msg -> Failure pos' msg
254 lookAhead :: Parser String
255 lookAhead = Parser $ \pos s -> Success pos [] s s
257 satisfy :: (Char -> Bool) -> Parser Char
259 Parser $ \pos s -> case s of
260 c:cs | p c -> Success (updatePos pos c) [c] cs c
261 _ -> Failure pos "Bad character"
263 char_ :: Char -> Parser ()
265 satisfy (== c) `message` (show c++" expected")
268 anyChar_ :: Parser ()
270 satisfy (const True) `message` "Unexpected end of file"
273 any2Chars_ :: Parser ()
274 any2Chars_ = anyChar_ >> anyChar_
276 many :: Parser a -> Parser [a]
277 many p = many1 p `mplus` return []
279 many1 :: Parser a -> Parser [a]
280 many1 p = liftM2 (:) p (many p)
282 many_ :: Parser a -> Parser ()
283 many_ p = many1_ p `mplus` return ()
285 many1_ :: Parser a -> Parser ()
286 many1_ p = p >> many_ p
288 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
289 manySatisfy = many . satisfy
290 manySatisfy1 = many1 . satisfy
292 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
293 manySatisfy_ = many_ . satisfy
294 manySatisfy1_ = many1_ . satisfy
296 ------------------------------------------------------------------------
297 -- Parser of hsc syntax.
300 = Text SourcePos String
301 | Special SourcePos String String
303 parser :: Parser [Token]
306 t <- catchOutput_ text
310 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
311 return (if null t then rest else Text pos t : rest)
318 c:_ | isAlpha c || c == '_' -> do
320 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
322 c:_ | isHsSymbol c -> do
323 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
326 '-':'-':symb' | all (== '-') symb' -> do
327 return () `fakeOutput` symb
328 manySatisfy_ (/= '\n')
331 return () `fakeOutput` unescapeHashes symb
333 '\"':_ -> do anyChar_; hsString '\"'; text
334 '\'':_ -> do anyChar_; hsString '\''; text
335 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
336 _:_ -> do anyChar_; text
338 hsString :: Char -> Parser ()
343 c:_ | c == quote -> anyChar_
348 char_ '\\' `mplus` return ()
350 | otherwise -> do any2Chars_; hsString quote
351 _:_ -> do anyChar_; hsString quote
353 hsComment :: Parser ()
358 '-':'}':_ -> any2Chars_
359 '{':'-':_ -> do any2Chars_; hsComment; hsComment
360 _:_ -> do anyChar_; hsComment
362 linePragma :: Parser ()
366 satisfy (\c -> c == 'L' || c == 'l')
367 satisfy (\c -> c == 'I' || c == 'i')
368 satisfy (\c -> c == 'N' || c == 'n')
369 satisfy (\c -> c == 'E' || c == 'e')
370 manySatisfy1_ isSpace
371 line <- liftM read $ manySatisfy1 isDigit
372 manySatisfy1_ isSpace
374 name <- manySatisfy (/= '\"')
380 setPos (SourcePos name (line - 1))
382 isHsSymbol :: Char -> Bool
383 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
384 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
385 isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True
386 isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True
387 isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True
388 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
389 isHsSymbol '~' = True
392 unescapeHashes :: String -> String
393 unescapeHashes [] = []
394 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
395 unescapeHashes (c:s) = c : unescapeHashes s
397 lookAheadC :: Parser String
398 lookAheadC = liftM joinLines lookAhead
401 joinLines ('\\':'\n':s) = joinLines s
402 joinLines (c:s) = c : joinLines s
404 satisfyC :: (Char -> Bool) -> Parser Char
408 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
411 charC_ :: Char -> Parser ()
413 satisfyC (== c) `message` (show c++" expected")
416 anyCharC_ :: Parser ()
418 satisfyC (const True) `message` "Unexpected end of file"
421 any2CharsC_ :: Parser ()
422 any2CharsC_ = anyCharC_ >> anyCharC_
424 manySatisfyC :: (Char -> Bool) -> Parser String
425 manySatisfyC = many . satisfyC
427 manySatisfyC_ :: (Char -> Bool) -> Parser ()
428 manySatisfyC_ = many_ . satisfyC
430 special :: Parser Token
432 manySatisfyC_ (\c -> isSpace c && c /= '\n')
437 manySatisfyC_ isSpace
438 sp <- keyArg (== '\n')
441 _ -> keyArg (const False)
443 keyArg :: (Char -> Bool) -> Parser Token
446 key <- keyword `message` "hsc keyword or '{' expected"
447 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
448 arg <- catchOutput_ (argument eol)
449 return (Special pos key arg)
451 keyword :: Parser String
453 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
454 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
457 argument :: (Char -> Bool) -> Parser ()
462 c:_ | eol c -> do anyCharC_; argument eol
464 '\"':_ -> do anyCharC_; cString '\"'; argument eol
465 '\'':_ -> do anyCharC_; cString '\''; argument eol
466 '(':_ -> do anyCharC_; nested ')'; argument eol
468 '/':'*':_ -> do any2CharsC_; cComment; argument eol
470 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
471 '[':_ -> do anyCharC_; nested ']'; argument eol
473 '{':_ -> do anyCharC_; nested '}'; argument eol
475 _:_ -> do anyCharC_; argument eol
477 nested :: Char -> Parser ()
478 nested c = do argument (== '\n'); charC_ c
480 cComment :: Parser ()
485 '*':'/':_ -> do any2CharsC_
486 _:_ -> do anyCharC_; cComment
488 cString :: Char -> Parser ()
493 c:_ | c == quote -> anyCharC_
494 '\\':_:_ -> do any2CharsC_; cString quote
495 _:_ -> do anyCharC_; cString quote
497 ------------------------------------------------------------------------
498 -- Write the output files.
500 splitName :: String -> (String, String)
502 case break (== '/') name of
503 (file, []) -> ([], file)
504 (dir, sep:rest) -> (dir++sep:restDir, restFile)
506 (restDir, restFile) = splitName rest
508 splitExt :: String -> (String, String)
510 case break (== '.') name of
511 (base, []) -> (base, [])
512 (base, sepRest@(sep:rest))
513 | null restExt -> (base, sepRest)
514 | otherwise -> (base++sep:restBase, restExt)
516 (restBase, restExt) = splitExt rest
518 output :: [Flag] -> String -> [Token] -> IO ()
519 output flags name toks = do
521 (outName, outDir, outBase) <- case [f | Output f <- flags] of
522 [] -> if not (null ext) && last ext == 'c'
523 then return (dir++base++init ext, dir, base)
526 then return (dir++base++"_out.hs", dir, base)
527 else return (dir++base++".hs", dir, base)
529 (dir, file) = splitName name
530 (base, ext) = splitExt file
532 (dir, file) = splitName f
533 (base, _) = splitExt file
534 in return (f, dir, base)
535 _ -> onlyOne "output file"
537 let cProgName = outDir++outBase++"_hsc_make.c"
538 oProgName = outDir++outBase++"_hsc_make.o"
539 progName = outDir++outBase++"_hsc_make"
540 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
541 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
542 -- via GHC has changed a few times, so this seems to be the only way... :-P * * *
545 outHFile = outBase++"_hsc.h"
546 outHName = outDir++outHFile
547 outCName = outDir++outBase++"_hsc.c"
549 beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
552 | null outDir = dosifyPath ("./" ++ progName)
553 | otherwise = progName
555 let specials = [(pos, key, arg) | Special pos key arg <- toks]
557 let needsC = any (\(_, key, _) -> key == "def") specials
560 let includeGuard = map fixChar outHName
562 fixChar c | isAlphaNum c = toUpper c
565 compiler <- case [c | Compiler c <- flags] of
567 mb_path <- findExecutable default_compiler
569 Nothing -> die ("Can't find "++default_compiler++"\n")
570 Just path -> return path
571 cs -> return (last cs)
573 linker <- case [l | Linker l <- flags] of
574 [] -> return compiler
575 ls -> return (last ls)
577 writeFile cProgName $
578 concatMap outFlagHeaderCProg flags++
579 concatMap outHeaderCProg specials++
580 "\nint main (int argc, char *argv [])\n{\n"++
581 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
582 outHsLine (SourcePos name 0)++
583 concatMap outTokenHs toks++
586 -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
587 -- so we use something slightly more complicated. :-P
588 when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
591 rawSystemL ("compiling " ++ cProgName) beVerbose compiler
593 ++ [f | CompFlag f <- flags]
597 finallyRemove cProgName $ do
599 rawSystemL ("linking " ++ oProgName) beVerbose linker
600 ( [f | LinkFlag f <- flags]
604 finallyRemove oProgName $ do
606 rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
607 finallyRemove progName $ do
609 when needsH $ writeFile outHName $
610 "#ifndef "++includeGuard++"\n" ++
611 "#define "++includeGuard++"\n" ++
612 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
613 "#include <Rts.h>\n" ++
615 "#include <HsFFI.h>\n" ++
618 "#define HsChar int\n" ++
620 concatMap outFlagH flags++
621 concatMap outTokenH specials++
624 when needsC $ writeFile outCName $
625 "#include \""++outHFile++"\"\n"++
626 concatMap outTokenC specials
627 -- NB. outHFile not outHName; works better when processed
628 -- by gcc or mkdependC.
630 rawSystemL :: String -> Bool -> FilePath -> [String] -> IO ()
631 rawSystemL action flg prog args = do
632 let cmdLine = prog++" "++unwords args
633 when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
634 exitStatus <- rawSystem prog args
636 ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
639 rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
640 rawSystemWithStdOutL action flg prog args outFile = do
641 let cmdLine = prog++" "++unwords args++" >"++outFile
642 when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
643 #ifndef HAVE_runProcess
644 exitStatus <- system cmdLine
646 hOut <- openFile outFile WriteMode
647 process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
648 exitStatus <- waitForProcess process
652 ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
655 -- delay the cleanup of generated files until the end; attempts to
656 -- get around intermittent failure to delete files which has
657 -- just been exec'ed by a sub-process (Win32 only.)
658 finallyRemove :: FilePath -> IO a -> IO a
659 finallyRemove fp act =
661 (const $ noisyRemove fp)
665 catch (removeFile fpath)
666 (\ e -> hPutStrLn stderr ("Failed to remove file " ++ fpath ++ "; error= " ++ show e))
668 onlyOne :: String -> IO a
669 onlyOne what = die ("Only one "++what++" may be specified\n")
671 outFlagHeaderCProg :: Flag -> String
672 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
673 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
674 outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n"
675 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
676 outFlagHeaderCProg _ = ""
678 outHeaderCProg :: (SourcePos, String, String) -> String
679 outHeaderCProg (pos, key, arg) = case key of
680 "include" -> outCLine pos++"#include "++arg++"\n"
681 "define" -> outCLine pos++"#define "++arg++"\n"
682 "undef" -> outCLine pos++"#undef "++arg++"\n"
684 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
685 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
687 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
688 "let" -> case break (== '=') arg of
690 (header, _:body) -> case break isSpace header of
693 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
694 "printf ("++joinLines body++");\n"
697 joinLines = concat . intersperse " \\\n" . lines
699 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
700 outHeaderHs flags inH toks =
702 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
703 " printf (\"{-# OPTIONS -optc-D" ++
704 "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
705 "__GLASGOW_HASKELL__);\n" ++
708 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
709 Just f -> outInclude ("\""++f++"\"")
711 outFlag (Include f) = outInclude f
712 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
713 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
715 outSpecial (pos, key, arg) = case key of
716 "include" -> outInclude arg
717 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
719 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
721 goodForOptD arg = case arg of
723 c:_ | isSpace c -> True
726 toOptD arg = case break isSpace arg of
728 (name, _:value) -> name++'=':dropWhile isSpace value
730 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
731 " printf (\"{-# OPTIONS %s #-}\\n\", \""++
732 showCString s++"\");\n"++
734 " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
735 showCString s++"\");\n"++
738 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
739 " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++
740 showCString s++"\");\n"++
742 " printf (\"{-# INCLUDE %s #-}\\n\", \""++
743 showCString s++"\");\n"++
746 outTokenHs :: Token -> String
747 outTokenHs (Text pos txt) =
748 case break (== '\n') txt of
749 (allTxt, []) -> outText allTxt
751 outText (first++"\n")++
755 outText s = " fputs (\""++showCString s++"\", stdout);\n"
756 outTokenHs (Special pos key arg) =
762 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
764 "enum" -> outCLine pos++outEnum arg
765 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
767 outEnum :: String -> String
769 case break (== ',') arg of
771 (t, _:afterT) -> case break (== ',') afterT of
774 enums (_:s) = case break (== ',') s of
776 this = case break (== '=') $ dropWhile isSpace enum of
778 " hsc_enum ("++t++", "++f++", " ++
779 "hsc_haskellize (\""++name++"\"), "++
782 " hsc_enum ("++t++", "++f++", " ++
783 "printf (\"%s\", \""++hsName++"\"), "++
788 outFlagH :: Flag -> String
789 outFlagH (Include f) = "#include "++f++"\n"
790 outFlagH (Define n Nothing) = "#define "++n++" 1\n"
791 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
794 outTokenH :: (SourcePos, String, String) -> String
795 outTokenH (pos, key, arg) =
797 "include" -> outCLine pos++"#include "++arg++"\n"
798 "define" -> outCLine pos++"#define " ++arg++"\n"
799 "undef" -> outCLine pos++"#undef " ++arg++"\n"
800 "def" -> outCLine pos++case arg of
801 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
802 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
803 'i':'n':'l':'i':'n':'e':' ':_ ->
804 "#ifdef __GNUC__\n" ++
808 _ -> "extern "++header++";\n"
809 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
810 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
813 outTokenC :: (SourcePos, String, String) -> String
814 outTokenC (pos, key, arg) =
817 's':'t':'r':'u':'c':'t':' ':_ -> ""
818 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
819 'i':'n':'l':'i':'n':'e':' ':arg' ->
820 case span (\c -> c /= '{' && c /= '=') arg' of
823 "#ifndef __GNUC__\n" ++
827 "\n#ifndef __GNUC__\n" ++
832 _ -> outCLine pos++arg++"\n"
833 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
836 conditional :: String -> Bool
837 conditional "if" = True
838 conditional "ifdef" = True
839 conditional "ifndef" = True
840 conditional "elif" = True
841 conditional "else" = True
842 conditional "endif" = True
843 conditional "error" = True
844 conditional "warning" = True
845 conditional _ = False
847 outCLine :: SourcePos -> String
848 outCLine (SourcePos name line) =
849 "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
851 outHsLine :: SourcePos -> String
852 outHsLine (SourcePos name line) =
853 " hsc_line ("++show (line + 1)++", \""++
854 showCString name++"\");\n"
856 showCString :: String -> String
857 showCString = concatMap showCChar
859 showCChar '\"' = "\\\""
860 showCChar '\'' = "\\\'"
861 showCChar '?' = "\\?"
862 showCChar '\\' = "\\\\"
863 showCChar c | c >= ' ' && c <= '~' = [c]
864 showCChar '\a' = "\\a"
865 showCChar '\b' = "\\b"
866 showCChar '\f' = "\\f"
867 showCChar '\n' = "\\n\"\n \""
868 showCChar '\r' = "\\r"
869 showCChar '\t' = "\\t"
870 showCChar '\v' = "\\v"
872 intToDigit (ord c `quot` 64),
873 intToDigit (ord c `quot` 8 `mod` 8),
874 intToDigit (ord c `mod` 8)]
876 -----------------------------------------
877 -- Modified version from ghc/compiler/SysTools
878 -- Convert paths foo/baz to foo\baz on Windows
880 subst :: Char -> Char -> String -> String
881 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
882 subst a b = map (\x -> if x == a then b else x)
887 dosifyPath :: String -> String
888 dosifyPath = subst '/' '\\'
890 -- (getExecDir cmd) returns the directory in which the current
891 -- executable, which should be called 'cmd', is running
892 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
893 -- you'll get "/a/b/c" back as the result
894 getExecDir :: String -> IO (Maybe String)
896 getExecPath >>= maybe (return Nothing) removeCmdSuffix
897 where unDosifyPath = subst '\\' '/'
898 initN n = reverse . drop n . reverse
899 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
901 getExecPath :: IO (Maybe String)
902 #if defined(mingw32_HOST_OS)
904 allocaArray len $ \buf -> do
905 ret <- getModuleFileName nullPtr buf len
906 if ret == 0 then return Nothing
907 else liftM Just $ peekCString buf
908 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
910 foreign import stdcall unsafe "GetModuleFileNameA"
911 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
913 getExecPath = return Nothing