1 {-# LANGUAGE CPP, ForeignFunctionInterface #-}
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 System.Cmd ( 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 )
61 import Distribution.Text
62 import qualified Paths_hsc2hs
65 version = "hsc2hs version 0.66\n"
77 | Define String (Maybe String)
81 template_flag :: Flag -> Bool
82 template_flag (Template _) = True
83 template_flag _ = False
85 include :: String -> Flag
86 include s@('\"':_) = Include s
87 include s@('<' :_) = Include s
88 include s = Include ("\""++s++"\"")
90 define :: String -> Flag
91 define s = case break (== '=') s of
92 (name, []) -> Define name Nothing
93 (name, _:value) -> Define name (Just value)
95 options :: [OptDescr Flag]
97 Option ['o'] ["output"] (ReqArg Output "FILE")
98 "name of main output file",
99 Option ['t'] ["template"] (ReqArg Template "FILE")
101 Option ['c'] ["cc"] (ReqArg Compiler "PROG")
103 Option ['l'] ["ld"] (ReqArg Linker "PROG")
105 Option ['C'] ["cflag"] (ReqArg CompFlag "FLAG")
106 "flag to pass to the C compiler",
107 Option ['I'] [] (ReqArg (CompFlag . ("-I"++)) "DIR")
108 "passed to the C compiler",
109 Option ['L'] ["lflag"] (ReqArg LinkFlag "FLAG")
110 "flag to pass to the linker",
111 Option ['i'] ["include"] (ReqArg include "FILE")
112 "as if placed in the source",
113 Option ['D'] ["define"] (ReqArg define "NAME[=VALUE]")
114 "as if placed in the source",
115 Option [] ["no-compile"] (NoArg NoCompile)
116 "stop after writing *_hsc_make.c",
117 Option ['v'] ["verbose"] (NoArg Verbose)
118 "dump commands to stderr",
119 Option ['?'] ["help"] (NoArg Help)
120 "display this help and exit",
121 Option ['V'] ["version"] (NoArg Version)
122 "output version information and exit" ]
126 prog <- getProgramName
127 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
129 let (flags, files, errs) = getOpt Permute options args
131 -- If there is no Template flag explicitly specified, try
132 -- to find one by looking near the executable. This only
133 -- works on Win32 or Hugs (getExecDir). On Unix, there's a wrapper
134 -- script which specifies an explicit template flag.
135 flags_w_tpl0 <- if any template_flag flags then
138 do mb_path <- getExecDir "/bin/hsc2hs.exe"
143 -- Euch, this is horrible. Unfortunately
144 -- Paths_hsc2hs isn't too useful for a
145 -- relocatable binary, though.
146 let templ = path ++ "/hsc2hs-" ++ display Paths_hsc2hs.version ++ "/template-hsc.h"
147 flg <- doesFileExist templ
149 then return ((Template templ):)
151 return (add_opt flags)
153 -- take only the last --template flag on the cmd line
155 (before,tpl:after) = break template_flag (reverse flags_w_tpl0)
156 flags_w_tpl = reverse (before ++ tpl : filter (not.template_flag) after)
158 case (files, errs) of
160 | any isHelp flags_w_tpl -> bye (usageInfo header options)
161 | any isVersion flags_w_tpl -> bye version
163 isHelp Help = True; isHelp _ = False
164 isVersion Version = True; isVersion _ = False
165 ((_:_), []) -> mapM_ (processFile flags_w_tpl) files
166 (_, _ ) -> die (concat errs ++ usageInfo header options)
168 getProgramName :: IO String
169 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
170 where str `withoutSuffix` suff
171 | suff `isSuffixOf` str = take (length str - length suff) str
174 bye :: String -> IO a
175 bye s = putStr s >> exitWith ExitSuccess
177 die :: String -> IO a
178 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
180 processFile :: [Flag] -> String -> IO ()
181 processFile flags name
182 = do let file_name = dosifyPath name
183 s <- readFile file_name
185 Parser p -> case p (SourcePos file_name 1) s of
186 Success _ _ _ toks -> output flags file_name toks
187 Failure (SourcePos name' line) msg ->
188 die (name'++":"++show line++": "++msg++"\n")
190 ------------------------------------------------------------------------
191 -- A deterministic parser which remembers the text which has been parsed.
193 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
195 data ParseResult a = Success !SourcePos String String a
196 | Failure !SourcePos String
198 data SourcePos = SourcePos String !Int
200 updatePos :: SourcePos -> Char -> SourcePos
201 updatePos pos@(SourcePos name line) ch = case ch of
202 '\n' -> SourcePos name (line + 1)
205 instance Monad Parser where
206 return a = Parser $ \pos s -> Success pos [] s a
208 Parser $ \pos s -> case m pos s of
209 Success pos' out1 s' a -> case k a of
210 Parser k' -> case k' pos' s' of
211 Success pos'' out2 imp'' b ->
212 Success pos'' (out1++out2) imp'' b
213 Failure pos'' msg -> Failure pos'' msg
214 Failure pos' msg -> Failure pos' msg
215 fail msg = Parser $ \pos _ -> Failure pos msg
217 instance MonadPlus Parser where
219 Parser m `mplus` Parser n =
220 Parser $ \pos s -> case m pos s of
221 success@(Success _ _ _ _) -> success
222 Failure _ _ -> n pos s
224 getPos :: Parser SourcePos
225 getPos = Parser $ \pos s -> Success pos [] s pos
227 setPos :: SourcePos -> Parser ()
228 setPos pos = Parser $ \_ s -> Success pos [] s ()
230 message :: Parser a -> String -> Parser a
231 Parser m `message` msg =
232 Parser $ \pos s -> case m pos s of
233 success@(Success _ _ _ _) -> success
234 Failure pos' _ -> Failure pos' msg
236 catchOutput_ :: Parser a -> Parser String
237 catchOutput_ (Parser m) =
238 Parser $ \pos s -> case m pos s of
239 Success pos' out s' _ -> Success pos' [] s' out
240 Failure pos' msg -> Failure pos' msg
242 fakeOutput :: Parser a -> String -> Parser a
243 Parser m `fakeOutput` out =
244 Parser $ \pos s -> case m pos s of
245 Success pos' _ s' a -> Success pos' out s' a
246 Failure pos' msg -> Failure pos' msg
248 lookAhead :: Parser String
249 lookAhead = Parser $ \pos s -> Success pos [] s s
251 satisfy :: (Char -> Bool) -> Parser Char
253 Parser $ \pos s -> case s of
254 c:cs | p c -> Success (updatePos pos c) [c] cs c
255 _ -> Failure pos "Bad character"
257 char_ :: Char -> Parser ()
259 satisfy (== c) `message` (show c++" expected")
262 anyChar_ :: Parser ()
264 satisfy (const True) `message` "Unexpected end of file"
267 any2Chars_ :: Parser ()
268 any2Chars_ = anyChar_ >> anyChar_
270 many :: Parser a -> Parser [a]
271 many p = many1 p `mplus` return []
273 many1 :: Parser a -> Parser [a]
274 many1 p = liftM2 (:) p (many p)
276 many_ :: Parser a -> Parser ()
277 many_ p = many1_ p `mplus` return ()
279 many1_ :: Parser a -> Parser ()
280 many1_ p = p >> many_ p
282 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
283 manySatisfy = many . satisfy
284 manySatisfy1 = many1 . satisfy
286 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
287 manySatisfy_ = many_ . satisfy
288 manySatisfy1_ = many1_ . satisfy
290 ------------------------------------------------------------------------
291 -- Parser of hsc syntax.
294 = Text SourcePos String
295 | Special SourcePos String String
297 parser :: Parser [Token]
300 t <- catchOutput_ text
304 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
305 return (if null t then rest else Text pos t : rest)
312 c:_ | isAlpha c || c == '_' -> do
314 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
316 c:_ | isHsSymbol c -> do
317 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
320 '-':'-':symb' | all (== '-') symb' -> do
321 return () `fakeOutput` symb
322 manySatisfy_ (/= '\n')
325 return () `fakeOutput` unescapeHashes symb
327 '\"':_ -> do anyChar_; hsString '\"'; text
328 '\'':_ -> do anyChar_; hsString '\''; text
329 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
330 _:_ -> do anyChar_; text
332 hsString :: Char -> Parser ()
337 c:_ | c == quote -> anyChar_
342 char_ '\\' `mplus` return ()
344 | otherwise -> do any2Chars_; hsString quote
345 _:_ -> do anyChar_; hsString quote
347 hsComment :: Parser ()
352 '-':'}':_ -> any2Chars_
353 '{':'-':_ -> do any2Chars_; hsComment; hsComment
354 _:_ -> do anyChar_; hsComment
356 linePragma :: Parser ()
360 satisfy (\c -> c == 'L' || c == 'l')
361 satisfy (\c -> c == 'I' || c == 'i')
362 satisfy (\c -> c == 'N' || c == 'n')
363 satisfy (\c -> c == 'E' || c == 'e')
364 manySatisfy1_ isSpace
365 line <- liftM read $ manySatisfy1 isDigit
366 manySatisfy1_ isSpace
368 name <- manySatisfy (/= '\"')
374 setPos (SourcePos name (line - 1))
376 isHsSymbol :: Char -> Bool
377 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
378 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
379 isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True
380 isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True
381 isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True
382 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
383 isHsSymbol '~' = True
386 unescapeHashes :: String -> String
387 unescapeHashes [] = []
388 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
389 unescapeHashes (c:s) = c : unescapeHashes s
391 lookAheadC :: Parser String
392 lookAheadC = liftM joinLines lookAhead
395 joinLines ('\\':'\n':s) = joinLines s
396 joinLines (c:s) = c : joinLines s
398 satisfyC :: (Char -> Bool) -> Parser Char
402 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
405 charC_ :: Char -> Parser ()
407 satisfyC (== c) `message` (show c++" expected")
410 anyCharC_ :: Parser ()
412 satisfyC (const True) `message` "Unexpected end of file"
415 any2CharsC_ :: Parser ()
416 any2CharsC_ = anyCharC_ >> anyCharC_
418 manySatisfyC :: (Char -> Bool) -> Parser String
419 manySatisfyC = many . satisfyC
421 manySatisfyC_ :: (Char -> Bool) -> Parser ()
422 manySatisfyC_ = many_ . satisfyC
424 special :: Parser Token
426 manySatisfyC_ (\c -> isSpace c && c /= '\n')
431 manySatisfyC_ isSpace
432 sp <- keyArg (== '\n')
435 _ -> keyArg (const False)
437 keyArg :: (Char -> Bool) -> Parser Token
440 key <- keyword `message` "hsc keyword or '{' expected"
441 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
442 arg <- catchOutput_ (argument eol)
443 return (Special pos key arg)
445 keyword :: Parser String
447 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
448 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
451 argument :: (Char -> Bool) -> Parser ()
456 c:_ | eol c -> do anyCharC_; argument eol
458 '\"':_ -> do anyCharC_; cString '\"'; argument eol
459 '\'':_ -> do anyCharC_; cString '\''; argument eol
460 '(':_ -> do anyCharC_; nested ')'; argument eol
462 '/':'*':_ -> do any2CharsC_; cComment; argument eol
464 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
465 '[':_ -> do anyCharC_; nested ']'; argument eol
467 '{':_ -> do anyCharC_; nested '}'; argument eol
469 _:_ -> do anyCharC_; argument eol
471 nested :: Char -> Parser ()
472 nested c = do argument (== '\n'); charC_ c
474 cComment :: Parser ()
479 '*':'/':_ -> do any2CharsC_
480 _:_ -> do anyCharC_; cComment
482 cString :: Char -> Parser ()
487 c:_ | c == quote -> anyCharC_
488 '\\':_:_ -> do any2CharsC_; cString quote
489 _:_ -> do anyCharC_; cString quote
491 ------------------------------------------------------------------------
492 -- Write the output files.
494 splitName :: String -> (String, String)
496 case break (== '/') name of
497 (file, []) -> ([], file)
498 (dir, sep:rest) -> (dir++sep:restDir, restFile)
500 (restDir, restFile) = splitName rest
502 splitExt :: String -> (String, String)
504 case break (== '.') name of
505 (base, []) -> (base, [])
506 (base, sepRest@(sep:rest))
507 | null restExt -> (base, sepRest)
508 | otherwise -> (base++sep:restBase, restExt)
510 (restBase, restExt) = splitExt rest
512 output :: [Flag] -> String -> [Token] -> IO ()
513 output flags name toks = do
515 (outName, outDir, outBase) <- case [f | Output f <- flags] of
516 [] -> if not (null ext) && last ext == 'c'
517 then return (dir++base++init ext, dir, base)
520 then return (dir++base++"_out.hs", dir, base)
521 else return (dir++base++".hs", dir, base)
523 (dir, file) = splitName name
524 (base, ext) = splitExt file
526 (dir, file) = splitName f
527 (base, _) = splitExt file
528 in return (f, dir, base)
529 _ -> onlyOne "output file"
531 let cProgName = outDir++outBase++"_hsc_make.c"
532 oProgName = outDir++outBase++"_hsc_make.o"
533 progName = outDir++outBase++"_hsc_make"
534 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
535 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
536 -- via GHC has changed a few times, so this seems to be the only way... :-P * * *
539 outHFile = outBase++"_hsc.h"
540 outHName = outDir++outHFile
541 outCName = outDir++outBase++"_hsc.c"
543 beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
546 | null outDir = dosifyPath ("./" ++ progName)
547 | otherwise = progName
549 let specials = [(pos, key, arg) | Special pos key arg <- toks]
551 let needsC = any (\(_, key, _) -> key == "def") specials
554 let includeGuard = map fixChar outHName
556 fixChar c | isAlphaNum c = toUpper c
559 -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
560 -- Returns a native-format path
562 mb <- getExecDir "bin/hsc2hs.exe"
564 Nothing -> return def
566 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
567 flg <- doesFileExist ghc_path
572 -- On a Win32 installation we execute the hsc2hs binary directly,
573 -- with no --cc flags, so we'll call locateGhc here, which will
574 -- succeed, via getExecDir.
576 -- On a Unix installation, we'll run the wrapper script hsc2hs.sh
577 -- (called plain hsc2hs in the installed tree), which will pass
578 -- a suitable C compiler via --cc
580 -- The in-place installation always uses the wrapper script,
581 -- (called hsc2hs-inplace, generated from hsc2hs.sh)
582 compiler <- case [c | Compiler c <- flags] of
583 [] -> locateGhc "ghc"
584 cs -> return (last cs)
586 linker <- case [l | Linker l <- flags] of
587 [] -> locateGhc compiler
588 ls -> return (last ls)
590 writeFile cProgName $
591 concatMap outFlagHeaderCProg flags++
592 concatMap outHeaderCProg specials++
593 "\nint main (int argc, char *argv [])\n{\n"++
594 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
595 outHsLine (SourcePos name 0)++
596 concatMap outTokenHs toks++
599 -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
600 -- so we use something slightly more complicated. :-P
601 when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
604 rawSystemL ("compiling " ++ cProgName) beVerbose compiler
606 ++ [f | CompFlag f <- flags]
610 finallyRemove cProgName $ do
612 rawSystemL ("linking " ++ oProgName) beVerbose linker
613 ( [f | LinkFlag f <- flags]
617 finallyRemove oProgName $ do
619 rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
620 finallyRemove progName $ do
622 when needsH $ writeFile outHName $
623 "#ifndef "++includeGuard++"\n" ++
624 "#define "++includeGuard++"\n" ++
625 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
626 "#include <Rts.h>\n" ++
628 "#include <HsFFI.h>\n" ++
631 "#define HsChar int\n" ++
633 concatMap outFlagH flags++
634 concatMap outTokenH specials++
637 when needsC $ writeFile outCName $
638 "#include \""++outHFile++"\"\n"++
639 concatMap outTokenC specials
640 -- NB. outHFile not outHName; works better when processed
641 -- by gcc or mkdependC.
643 rawSystemL :: String -> Bool -> FilePath -> [String] -> IO ()
644 rawSystemL action flg prog args = do
645 let cmdLine = prog++" "++unwords args
646 when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
647 #ifndef HAVE_rawSystem
648 exitStatus <- system cmdLine
650 exitStatus <- rawSystem prog args
653 ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
656 rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
657 rawSystemWithStdOutL action flg prog args outFile = do
658 let cmdLine = prog++" "++unwords args++" >"++outFile
659 when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
660 #ifndef HAVE_runProcess
661 exitStatus <- system cmdLine
663 hOut <- openFile outFile WriteMode
664 process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
665 exitStatus <- waitForProcess process
669 ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
673 -- delay the cleanup of generated files until the end; attempts to
674 -- get around intermittent failure to delete files which has
675 -- just been exec'ed by a sub-process (Win32 only.)
676 finallyRemove :: FilePath -> IO a -> IO a
677 finallyRemove fp act =
679 (const $ noisyRemove fp)
683 catch (removeFile fpath)
684 (\ e -> hPutStrLn stderr ("Failed to remove file " ++ fpath ++ "; error= " ++ show e))
685 onlyOne :: String -> IO a
686 onlyOne what = die ("Only one "++what++" may be specified\n")
688 outFlagHeaderCProg :: Flag -> String
689 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
690 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
691 outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n"
692 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
693 outFlagHeaderCProg _ = ""
695 outHeaderCProg :: (SourcePos, String, String) -> String
696 outHeaderCProg (pos, key, arg) = case key of
697 "include" -> outCLine pos++"#include "++arg++"\n"
698 "define" -> outCLine pos++"#define "++arg++"\n"
699 "undef" -> outCLine pos++"#undef "++arg++"\n"
701 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
702 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
704 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
705 "let" -> case break (== '=') arg of
707 (header, _:body) -> case break isSpace header of
710 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
711 "printf ("++joinLines body++");\n"
714 joinLines = concat . intersperse " \\\n" . lines
716 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
717 outHeaderHs flags inH toks =
719 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
720 " printf (\"{-# OPTIONS -optc-D" ++
721 "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
722 "__GLASGOW_HASKELL__);\n" ++
725 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
726 Just f -> outInclude ("\""++f++"\"")
728 outFlag (Include f) = outInclude f
729 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
730 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
732 outSpecial (pos, key, arg) = case key of
733 "include" -> outInclude arg
734 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
736 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
738 goodForOptD arg = case arg of
740 c:_ | isSpace c -> True
743 toOptD arg = case break isSpace arg of
745 (name, _:value) -> name++'=':dropWhile isSpace value
747 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
748 " printf (\"{-# OPTIONS %s #-}\\n\", \""++
749 showCString s++"\");\n"++
751 " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
752 showCString s++"\");\n"++
755 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
756 " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++
757 showCString s++"\");\n"++
759 " printf (\"{-# INCLUDE %s #-}\\n\", \""++
760 showCString s++"\");\n"++
763 outTokenHs :: Token -> String
764 outTokenHs (Text pos txt) =
765 case break (== '\n') txt of
766 (allTxt, []) -> outText allTxt
768 outText (first++"\n")++
772 outText s = " fputs (\""++showCString s++"\", stdout);\n"
773 outTokenHs (Special pos key arg) =
779 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
781 "enum" -> outCLine pos++outEnum arg
782 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
784 outEnum :: String -> String
786 case break (== ',') arg of
788 (t, _:afterT) -> case break (== ',') afterT of
791 enums (_:s) = case break (== ',') s of
793 this = case break (== '=') $ dropWhile isSpace enum of
795 " hsc_enum ("++t++", "++f++", " ++
796 "hsc_haskellize (\""++name++"\"), "++
799 " hsc_enum ("++t++", "++f++", " ++
800 "printf (\"%s\", \""++hsName++"\"), "++
805 outFlagH :: Flag -> String
806 outFlagH (Include f) = "#include "++f++"\n"
807 outFlagH (Define n Nothing) = "#define "++n++" 1\n"
808 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
811 outTokenH :: (SourcePos, String, String) -> String
812 outTokenH (pos, key, arg) =
814 "include" -> outCLine pos++"#include "++arg++"\n"
815 "define" -> outCLine pos++"#define " ++arg++"\n"
816 "undef" -> outCLine pos++"#undef " ++arg++"\n"
817 "def" -> outCLine pos++case arg of
818 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
819 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
820 'i':'n':'l':'i':'n':'e':' ':_ ->
821 "#ifdef __GNUC__\n" ++
825 _ -> "extern "++header++";\n"
826 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
827 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
830 outTokenC :: (SourcePos, String, String) -> String
831 outTokenC (pos, key, arg) =
834 's':'t':'r':'u':'c':'t':' ':_ -> ""
835 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
836 'i':'n':'l':'i':'n':'e':' ':arg' ->
837 case span (\c -> c /= '{' && c /= '=') arg' of
840 "#ifndef __GNUC__\n" ++
844 "\n#ifndef __GNUC__\n" ++
849 _ -> outCLine pos++arg++"\n"
850 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
853 conditional :: String -> Bool
854 conditional "if" = True
855 conditional "ifdef" = True
856 conditional "ifndef" = True
857 conditional "elif" = True
858 conditional "else" = True
859 conditional "endif" = True
860 conditional "error" = True
861 conditional "warning" = True
862 conditional _ = False
864 outCLine :: SourcePos -> String
865 outCLine (SourcePos name line) =
866 "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
868 outHsLine :: SourcePos -> String
869 outHsLine (SourcePos name line) =
870 " hsc_line ("++show (line + 1)++", \""++
871 showCString name++"\");\n"
873 showCString :: String -> String
874 showCString = concatMap showCChar
876 showCChar '\"' = "\\\""
877 showCChar '\'' = "\\\'"
878 showCChar '?' = "\\?"
879 showCChar '\\' = "\\\\"
880 showCChar c | c >= ' ' && c <= '~' = [c]
881 showCChar '\a' = "\\a"
882 showCChar '\b' = "\\b"
883 showCChar '\f' = "\\f"
884 showCChar '\n' = "\\n\"\n \""
885 showCChar '\r' = "\\r"
886 showCChar '\t' = "\\t"
887 showCChar '\v' = "\\v"
889 intToDigit (ord c `quot` 64),
890 intToDigit (ord c `quot` 8 `mod` 8),
891 intToDigit (ord c `mod` 8)]
893 -----------------------------------------
894 -- Modified version from ghc/compiler/SysTools
895 -- Convert paths foo/baz to foo\baz on Windows
897 subst :: Char -> Char -> String -> String
898 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
899 subst a b = map (\x -> if x == a then b else x)
904 dosifyPath :: String -> String
905 dosifyPath = subst '/' '\\'
907 -- (getExecDir cmd) returns the directory in which the current
908 -- executable, which should be called 'cmd', is running
909 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
910 -- you'll get "/a/b/c" back as the result
911 getExecDir :: String -> IO (Maybe String)
913 getExecPath >>= maybe (return Nothing) removeCmdSuffix
914 where unDosifyPath = subst '\\' '/'
915 initN n = reverse . drop n . reverse
916 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
918 getExecPath :: IO (Maybe String)
919 #if defined(mingw32_HOST_OS)
921 allocaArray len $ \buf -> do
922 ret <- getModuleFileName nullPtr buf len
923 if ret == 0 then return Nothing
924 else liftM Just $ peekCString buf
925 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
927 foreign import stdcall unsafe "GetModuleFileNameA"
928 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
930 getExecPath = return Nothing