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_tpl0 <- 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)
151 -- take only the last --template flag on the cmd line
153 (before,tpl:after) = break template_flag (reverse flags_w_tpl0)
154 flags_w_tpl = reverse (before ++ tpl : filter (not.template_flag) after)
156 case (files, errs) of
158 | any isHelp flags_w_tpl -> bye (usageInfo header options)
159 | any isVersion flags_w_tpl -> bye version
161 isHelp Help = True; isHelp _ = False
162 isVersion Version = True; isVersion _ = False
163 ((_:_), []) -> mapM_ (processFile flags_w_tpl) files
164 (_, _ ) -> die (concat errs ++ usageInfo header options)
166 getProgramName :: IO String
167 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
168 where str `withoutSuffix` suff
169 | suff `isSuffixOf` str = take (length str - length suff) str
172 bye :: String -> IO a
173 bye s = putStr s >> exitWith ExitSuccess
175 die :: String -> IO a
176 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
178 processFile :: [Flag] -> String -> IO ()
179 processFile flags name
180 = do let file_name = dosifyPath name
181 s <- readFile file_name
183 Parser p -> case p (SourcePos file_name 1) s of
184 Success _ _ _ toks -> output flags file_name toks
185 Failure (SourcePos name' line) msg ->
186 die (name'++":"++show line++": "++msg++"\n")
188 ------------------------------------------------------------------------
189 -- A deterministic parser which remembers the text which has been parsed.
191 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
193 data ParseResult a = Success !SourcePos String String a
194 | Failure !SourcePos String
196 data SourcePos = SourcePos String !Int
198 updatePos :: SourcePos -> Char -> SourcePos
199 updatePos pos@(SourcePos name line) ch = case ch of
200 '\n' -> SourcePos name (line + 1)
203 instance Monad Parser where
204 return a = Parser $ \pos s -> Success pos [] s a
206 Parser $ \pos s -> case m pos s of
207 Success pos' out1 s' a -> case k a of
208 Parser k' -> case k' pos' s' of
209 Success pos'' out2 imp'' b ->
210 Success pos'' (out1++out2) imp'' b
211 Failure pos'' msg -> Failure pos'' msg
212 Failure pos' msg -> Failure pos' msg
213 fail msg = Parser $ \pos _ -> Failure pos msg
215 instance MonadPlus Parser where
217 Parser m `mplus` Parser n =
218 Parser $ \pos s -> case m pos s of
219 success@(Success _ _ _ _) -> success
220 Failure _ _ -> n pos s
222 getPos :: Parser SourcePos
223 getPos = Parser $ \pos s -> Success pos [] s pos
225 setPos :: SourcePos -> Parser ()
226 setPos pos = Parser $ \_ s -> Success pos [] s ()
228 message :: Parser a -> String -> Parser a
229 Parser m `message` msg =
230 Parser $ \pos s -> case m pos s of
231 success@(Success _ _ _ _) -> success
232 Failure pos' _ -> Failure pos' msg
234 catchOutput_ :: Parser a -> Parser String
235 catchOutput_ (Parser m) =
236 Parser $ \pos s -> case m pos s of
237 Success pos' out s' _ -> Success pos' [] s' out
238 Failure pos' msg -> Failure pos' msg
240 fakeOutput :: Parser a -> String -> Parser a
241 Parser m `fakeOutput` out =
242 Parser $ \pos s -> case m pos s of
243 Success pos' _ s' a -> Success pos' out s' a
244 Failure pos' msg -> Failure pos' msg
246 lookAhead :: Parser String
247 lookAhead = Parser $ \pos s -> Success pos [] s s
249 satisfy :: (Char -> Bool) -> Parser Char
251 Parser $ \pos s -> case s of
252 c:cs | p c -> Success (updatePos pos c) [c] cs c
253 _ -> Failure pos "Bad character"
255 char_ :: Char -> Parser ()
257 satisfy (== c) `message` (show c++" expected")
260 anyChar_ :: Parser ()
262 satisfy (const True) `message` "Unexpected end of file"
265 any2Chars_ :: Parser ()
266 any2Chars_ = anyChar_ >> anyChar_
268 many :: Parser a -> Parser [a]
269 many p = many1 p `mplus` return []
271 many1 :: Parser a -> Parser [a]
272 many1 p = liftM2 (:) p (many p)
274 many_ :: Parser a -> Parser ()
275 many_ p = many1_ p `mplus` return ()
277 many1_ :: Parser a -> Parser ()
278 many1_ p = p >> many_ p
280 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
281 manySatisfy = many . satisfy
282 manySatisfy1 = many1 . satisfy
284 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
285 manySatisfy_ = many_ . satisfy
286 manySatisfy1_ = many1_ . satisfy
288 ------------------------------------------------------------------------
289 -- Parser of hsc syntax.
292 = Text SourcePos String
293 | Special SourcePos String String
295 parser :: Parser [Token]
298 t <- catchOutput_ text
302 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
303 return (if null t then rest else Text pos t : rest)
310 c:_ | isAlpha c || c == '_' -> do
312 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
314 c:_ | isHsSymbol c -> do
315 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
318 '-':'-':symb' | all (== '-') symb' -> do
319 return () `fakeOutput` symb
320 manySatisfy_ (/= '\n')
323 return () `fakeOutput` unescapeHashes symb
325 '\"':_ -> do anyChar_; hsString '\"'; text
326 '\'':_ -> do anyChar_; hsString '\''; text
327 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
328 _:_ -> do anyChar_; text
330 hsString :: Char -> Parser ()
335 c:_ | c == quote -> anyChar_
340 char_ '\\' `mplus` return ()
342 | otherwise -> do any2Chars_; hsString quote
343 _:_ -> do anyChar_; hsString quote
345 hsComment :: Parser ()
350 '-':'}':_ -> any2Chars_
351 '{':'-':_ -> do any2Chars_; hsComment; hsComment
352 _:_ -> do anyChar_; hsComment
354 linePragma :: Parser ()
358 satisfy (\c -> c == 'L' || c == 'l')
359 satisfy (\c -> c == 'I' || c == 'i')
360 satisfy (\c -> c == 'N' || c == 'n')
361 satisfy (\c -> c == 'E' || c == 'e')
362 manySatisfy1_ isSpace
363 line <- liftM read $ manySatisfy1 isDigit
364 manySatisfy1_ isSpace
366 name <- manySatisfy (/= '\"')
372 setPos (SourcePos name (line - 1))
374 isHsSymbol :: Char -> Bool
375 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
376 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
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
384 unescapeHashes :: String -> String
385 unescapeHashes [] = []
386 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
387 unescapeHashes (c:s) = c : unescapeHashes s
389 lookAheadC :: Parser String
390 lookAheadC = liftM joinLines lookAhead
393 joinLines ('\\':'\n':s) = joinLines s
394 joinLines (c:s) = c : joinLines s
396 satisfyC :: (Char -> Bool) -> Parser Char
400 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
403 charC_ :: Char -> Parser ()
405 satisfyC (== c) `message` (show c++" expected")
408 anyCharC_ :: Parser ()
410 satisfyC (const True) `message` "Unexpected end of file"
413 any2CharsC_ :: Parser ()
414 any2CharsC_ = anyCharC_ >> anyCharC_
416 manySatisfyC :: (Char -> Bool) -> Parser String
417 manySatisfyC = many . satisfyC
419 manySatisfyC_ :: (Char -> Bool) -> Parser ()
420 manySatisfyC_ = many_ . satisfyC
422 special :: Parser Token
424 manySatisfyC_ (\c -> isSpace c && c /= '\n')
429 manySatisfyC_ isSpace
430 sp <- keyArg (== '\n')
433 _ -> keyArg (const False)
435 keyArg :: (Char -> Bool) -> Parser Token
438 key <- keyword `message` "hsc keyword or '{' expected"
439 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
440 arg <- catchOutput_ (argument eol)
441 return (Special pos key arg)
443 keyword :: Parser String
445 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
446 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
449 argument :: (Char -> Bool) -> Parser ()
454 c:_ | eol c -> do anyCharC_; argument eol
456 '\"':_ -> do anyCharC_; cString '\"'; argument eol
457 '\'':_ -> do anyCharC_; cString '\''; argument eol
458 '(':_ -> do anyCharC_; nested ')'; argument eol
460 '/':'*':_ -> do any2CharsC_; cComment; argument eol
462 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
463 '[':_ -> do anyCharC_; nested ']'; argument eol
465 '{':_ -> do anyCharC_; nested '}'; argument eol
467 _:_ -> do anyCharC_; argument eol
469 nested :: Char -> Parser ()
470 nested c = do argument (== '\n'); charC_ c
472 cComment :: Parser ()
477 '*':'/':_ -> do any2CharsC_
478 _:_ -> do anyCharC_; cComment
480 cString :: Char -> Parser ()
485 c:_ | c == quote -> anyCharC_
486 '\\':_:_ -> do any2CharsC_; cString quote
487 _:_ -> do anyCharC_; cString quote
489 ------------------------------------------------------------------------
490 -- Write the output files.
492 splitName :: String -> (String, String)
494 case break (== '/') name of
495 (file, []) -> ([], file)
496 (dir, sep:rest) -> (dir++sep:restDir, restFile)
498 (restDir, restFile) = splitName rest
500 splitExt :: String -> (String, String)
502 case break (== '.') name of
503 (base, []) -> (base, [])
504 (base, sepRest@(sep:rest))
505 | null restExt -> (base, sepRest)
506 | otherwise -> (base++sep:restBase, restExt)
508 (restBase, restExt) = splitExt rest
510 output :: [Flag] -> String -> [Token] -> IO ()
511 output flags name toks = do
513 (outName, outDir, outBase) <- case [f | Output f <- flags] of
514 [] -> if not (null ext) && last ext == 'c'
515 then return (dir++base++init ext, dir, base)
518 then return (dir++base++"_out.hs", dir, base)
519 else return (dir++base++".hs", dir, base)
521 (dir, file) = splitName name
522 (base, ext) = splitExt file
524 (dir, file) = splitName f
525 (base, _) = splitExt file
526 in return (f, dir, base)
527 _ -> onlyOne "output file"
529 let cProgName = outDir++outBase++"_hsc_make.c"
530 oProgName = outDir++outBase++"_hsc_make.o"
531 progName = outDir++outBase++"_hsc_make"
532 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
533 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
534 -- via GHC has changed a few times, so this seems to be the only way... :-P * * *
537 outHFile = outBase++"_hsc.h"
538 outHName = outDir++outHFile
539 outCName = outDir++outBase++"_hsc.c"
541 beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
544 | null outDir = dosifyPath ("./" ++ progName)
545 | otherwise = progName
547 let specials = [(pos, key, arg) | Special pos key arg <- toks]
549 let needsC = any (\(_, key, _) -> key == "def") specials
552 let includeGuard = map fixChar outHName
554 fixChar c | isAlphaNum c = toUpper c
557 -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
558 -- Returns a native-format path
560 mb <- getExecDir "bin/hsc2hs.exe"
562 Nothing -> return def
564 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
565 flg <- doesFileExist ghc_path
570 -- On a Win32 installation we execute the hsc2hs binary directly,
571 -- with no --cc flags, so we'll call locateGhc here, which will
572 -- succeed, via getExecDir.
574 -- On a Unix installation, we'll run the wrapper script hsc2hs.sh
575 -- (called plain hsc2hs in the installed tree), which will pass
576 -- a suitable C compiler via --cc
578 -- The in-place installation always uses the wrapper script,
579 -- (called hsc2hs-inplace, generated from hsc2hs.sh)
580 compiler <- case [c | Compiler c <- flags] of
581 [] -> locateGhc "ghc"
583 _ -> onlyOne "compiler"
585 linker <- case [l | Linker l <- flags] of
586 [] -> locateGhc compiler
588 _ -> onlyOne "linker"
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