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 )
62 version = "hsc2hs version 0.66\n"
74 | Define String (Maybe String)
78 template_flag :: Flag -> Bool
79 template_flag (Template _) = True
80 template_flag _ = False
82 include :: String -> Flag
83 include s@('\"':_) = Include s
84 include s@('<' :_) = Include s
85 include s = Include ("\""++s++"\"")
87 define :: String -> Flag
88 define s = case break (== '=') s of
89 (name, []) -> Define name Nothing
90 (name, _:value) -> Define name (Just value)
92 options :: [OptDescr Flag]
94 Option ['o'] ["output"] (ReqArg Output "FILE")
95 "name of main output file",
96 Option ['t'] ["template"] (ReqArg Template "FILE")
98 Option ['c'] ["cc"] (ReqArg Compiler "PROG")
100 Option ['l'] ["ld"] (ReqArg Linker "PROG")
102 Option ['C'] ["cflag"] (ReqArg CompFlag "FLAG")
103 "flag to pass to the C compiler",
104 Option ['I'] [] (ReqArg (CompFlag . ("-I"++)) "DIR")
105 "passed to the C compiler",
106 Option ['L'] ["lflag"] (ReqArg LinkFlag "FLAG")
107 "flag to pass to the linker",
108 Option ['i'] ["include"] (ReqArg include "FILE")
109 "as if placed in the source",
110 Option ['D'] ["define"] (ReqArg define "NAME[=VALUE]")
111 "as if placed in the source",
112 Option [] ["no-compile"] (NoArg NoCompile)
113 "stop after writing *_hsc_make.c",
114 Option ['v'] ["verbose"] (NoArg Verbose)
115 "dump commands to stderr",
116 Option ['?'] ["help"] (NoArg Help)
117 "display this help and exit",
118 Option ['V'] ["version"] (NoArg Version)
119 "output version information and exit" ]
123 prog <- getProgramName
124 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
126 let (flags, files, errs) = getOpt Permute options args
128 -- If there is no Template flag explicitly specified, try
129 -- to find one by looking near the executable. This only
130 -- works on Win32 or Hugs (getExecDir). On Unix, there's a wrapper
131 -- script which specifies an explicit template flag.
132 flags_w_tpl0 <- if any template_flag flags then
135 do mb_path <- getExecDir "/bin/hsc2hs.exe"
140 let templ = path ++ "/template-hsc.h"
141 flg <- doesFileExist templ
143 then return ((Template templ):)
145 return (add_opt flags)
147 -- take only the last --template flag on the cmd line
149 (before,tpl:after) = break template_flag (reverse flags_w_tpl0)
150 flags_w_tpl = reverse (before ++ tpl : filter (not.template_flag) after)
152 case (files, errs) of
154 | any isHelp flags_w_tpl -> bye (usageInfo header options)
155 | any isVersion flags_w_tpl -> bye version
157 isHelp Help = True; isHelp _ = False
158 isVersion Version = True; isVersion _ = False
159 ((_:_), []) -> mapM_ (processFile flags_w_tpl) files
160 (_, _ ) -> die (concat errs ++ usageInfo header options)
162 getProgramName :: IO String
163 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
164 where str `withoutSuffix` suff
165 | suff `isSuffixOf` str = take (length str - length suff) str
168 bye :: String -> IO a
169 bye s = putStr s >> exitWith ExitSuccess
171 die :: String -> IO a
172 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
174 processFile :: [Flag] -> String -> IO ()
175 processFile flags name
176 = do let file_name = dosifyPath name
177 s <- readFile file_name
179 Parser p -> case p (SourcePos file_name 1) s of
180 Success _ _ _ toks -> output flags file_name toks
181 Failure (SourcePos name' line) msg ->
182 die (name'++":"++show line++": "++msg++"\n")
184 ------------------------------------------------------------------------
185 -- A deterministic parser which remembers the text which has been parsed.
187 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
189 data ParseResult a = Success !SourcePos String String a
190 | Failure !SourcePos String
192 data SourcePos = SourcePos String !Int
194 updatePos :: SourcePos -> Char -> SourcePos
195 updatePos pos@(SourcePos name line) ch = case ch of
196 '\n' -> SourcePos name (line + 1)
199 instance Monad Parser where
200 return a = Parser $ \pos s -> Success pos [] s a
202 Parser $ \pos s -> case m pos s of
203 Success pos' out1 s' a -> case k a of
204 Parser k' -> case k' pos' s' of
205 Success pos'' out2 imp'' b ->
206 Success pos'' (out1++out2) imp'' b
207 Failure pos'' msg -> Failure pos'' msg
208 Failure pos' msg -> Failure pos' msg
209 fail msg = Parser $ \pos _ -> Failure pos msg
211 instance MonadPlus Parser where
213 Parser m `mplus` Parser n =
214 Parser $ \pos s -> case m pos s of
215 success@(Success _ _ _ _) -> success
216 Failure _ _ -> n pos s
218 getPos :: Parser SourcePos
219 getPos = Parser $ \pos s -> Success pos [] s pos
221 setPos :: SourcePos -> Parser ()
222 setPos pos = Parser $ \_ s -> Success pos [] s ()
224 message :: Parser a -> String -> Parser a
225 Parser m `message` msg =
226 Parser $ \pos s -> case m pos s of
227 success@(Success _ _ _ _) -> success
228 Failure pos' _ -> Failure pos' msg
230 catchOutput_ :: Parser a -> Parser String
231 catchOutput_ (Parser m) =
232 Parser $ \pos s -> case m pos s of
233 Success pos' out s' _ -> Success pos' [] s' out
234 Failure pos' msg -> Failure pos' msg
236 fakeOutput :: Parser a -> String -> Parser a
237 Parser m `fakeOutput` out =
238 Parser $ \pos s -> case m pos s of
239 Success pos' _ s' a -> Success pos' out s' a
240 Failure pos' msg -> Failure pos' msg
242 lookAhead :: Parser String
243 lookAhead = Parser $ \pos s -> Success pos [] s s
245 satisfy :: (Char -> Bool) -> Parser Char
247 Parser $ \pos s -> case s of
248 c:cs | p c -> Success (updatePos pos c) [c] cs c
249 _ -> Failure pos "Bad character"
251 char_ :: Char -> Parser ()
253 satisfy (== c) `message` (show c++" expected")
256 anyChar_ :: Parser ()
258 satisfy (const True) `message` "Unexpected end of file"
261 any2Chars_ :: Parser ()
262 any2Chars_ = anyChar_ >> anyChar_
264 many :: Parser a -> Parser [a]
265 many p = many1 p `mplus` return []
267 many1 :: Parser a -> Parser [a]
268 many1 p = liftM2 (:) p (many p)
270 many_ :: Parser a -> Parser ()
271 many_ p = many1_ p `mplus` return ()
273 many1_ :: Parser a -> Parser ()
274 many1_ p = p >> many_ p
276 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
277 manySatisfy = many . satisfy
278 manySatisfy1 = many1 . satisfy
280 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
281 manySatisfy_ = many_ . satisfy
282 manySatisfy1_ = many1_ . satisfy
284 ------------------------------------------------------------------------
285 -- Parser of hsc syntax.
288 = Text SourcePos String
289 | Special SourcePos String String
291 parser :: Parser [Token]
294 t <- catchOutput_ text
298 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
299 return (if null t then rest else Text pos t : rest)
306 c:_ | isAlpha c || c == '_' -> do
308 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
310 c:_ | isHsSymbol c -> do
311 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
314 '-':'-':symb' | all (== '-') symb' -> do
315 return () `fakeOutput` symb
316 manySatisfy_ (/= '\n')
319 return () `fakeOutput` unescapeHashes symb
321 '\"':_ -> do anyChar_; hsString '\"'; text
322 '\'':_ -> do anyChar_; hsString '\''; text
323 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
324 _:_ -> do anyChar_; text
326 hsString :: Char -> Parser ()
331 c:_ | c == quote -> anyChar_
336 char_ '\\' `mplus` return ()
338 | otherwise -> do any2Chars_; hsString quote
339 _:_ -> do anyChar_; hsString quote
341 hsComment :: Parser ()
346 '-':'}':_ -> any2Chars_
347 '{':'-':_ -> do any2Chars_; hsComment; hsComment
348 _:_ -> do anyChar_; hsComment
350 linePragma :: Parser ()
354 satisfy (\c -> c == 'L' || c == 'l')
355 satisfy (\c -> c == 'I' || c == 'i')
356 satisfy (\c -> c == 'N' || c == 'n')
357 satisfy (\c -> c == 'E' || c == 'e')
358 manySatisfy1_ isSpace
359 line <- liftM read $ manySatisfy1 isDigit
360 manySatisfy1_ isSpace
362 name <- manySatisfy (/= '\"')
368 setPos (SourcePos name (line - 1))
370 isHsSymbol :: Char -> Bool
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; isHsSymbol '@' = True; isHsSymbol '\\' = True
376 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
377 isHsSymbol '~' = True
380 unescapeHashes :: String -> String
381 unescapeHashes [] = []
382 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
383 unescapeHashes (c:s) = c : unescapeHashes s
385 lookAheadC :: Parser String
386 lookAheadC = liftM joinLines lookAhead
389 joinLines ('\\':'\n':s) = joinLines s
390 joinLines (c:s) = c : joinLines s
392 satisfyC :: (Char -> Bool) -> Parser Char
396 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
399 charC_ :: Char -> Parser ()
401 satisfyC (== c) `message` (show c++" expected")
404 anyCharC_ :: Parser ()
406 satisfyC (const True) `message` "Unexpected end of file"
409 any2CharsC_ :: Parser ()
410 any2CharsC_ = anyCharC_ >> anyCharC_
412 manySatisfyC :: (Char -> Bool) -> Parser String
413 manySatisfyC = many . satisfyC
415 manySatisfyC_ :: (Char -> Bool) -> Parser ()
416 manySatisfyC_ = many_ . satisfyC
418 special :: Parser Token
420 manySatisfyC_ (\c -> isSpace c && c /= '\n')
425 manySatisfyC_ isSpace
426 sp <- keyArg (== '\n')
429 _ -> keyArg (const False)
431 keyArg :: (Char -> Bool) -> Parser Token
434 key <- keyword `message` "hsc keyword or '{' expected"
435 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
436 arg <- catchOutput_ (argument eol)
437 return (Special pos key arg)
439 keyword :: Parser String
441 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
442 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
445 argument :: (Char -> Bool) -> Parser ()
450 c:_ | eol c -> do anyCharC_; argument eol
452 '\"':_ -> do anyCharC_; cString '\"'; argument eol
453 '\'':_ -> do anyCharC_; cString '\''; argument eol
454 '(':_ -> do anyCharC_; nested ')'; argument eol
456 '/':'*':_ -> do any2CharsC_; cComment; argument eol
458 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
459 '[':_ -> do anyCharC_; nested ']'; argument eol
461 '{':_ -> do anyCharC_; nested '}'; argument eol
463 _:_ -> do anyCharC_; argument eol
465 nested :: Char -> Parser ()
466 nested c = do argument (== '\n'); charC_ c
468 cComment :: Parser ()
473 '*':'/':_ -> do any2CharsC_
474 _:_ -> do anyCharC_; cComment
476 cString :: Char -> Parser ()
481 c:_ | c == quote -> anyCharC_
482 '\\':_:_ -> do any2CharsC_; cString quote
483 _:_ -> do anyCharC_; cString quote
485 ------------------------------------------------------------------------
486 -- Write the output files.
488 splitName :: String -> (String, String)
490 case break (== '/') name of
491 (file, []) -> ([], file)
492 (dir, sep:rest) -> (dir++sep:restDir, restFile)
494 (restDir, restFile) = splitName rest
496 splitExt :: String -> (String, String)
498 case break (== '.') name of
499 (base, []) -> (base, [])
500 (base, sepRest@(sep:rest))
501 | null restExt -> (base, sepRest)
502 | otherwise -> (base++sep:restBase, restExt)
504 (restBase, restExt) = splitExt rest
506 output :: [Flag] -> String -> [Token] -> IO ()
507 output flags name toks = do
509 (outName, outDir, outBase) <- case [f | Output f <- flags] of
510 [] -> if not (null ext) && last ext == 'c'
511 then return (dir++base++init ext, dir, base)
514 then return (dir++base++"_out.hs", dir, base)
515 else return (dir++base++".hs", dir, base)
517 (dir, file) = splitName name
518 (base, ext) = splitExt file
520 (dir, file) = splitName f
521 (base, _) = splitExt file
522 in return (f, dir, base)
523 _ -> onlyOne "output file"
525 let cProgName = outDir++outBase++"_hsc_make.c"
526 oProgName = outDir++outBase++"_hsc_make.o"
527 progName = outDir++outBase++"_hsc_make"
528 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
529 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
530 -- via GHC has changed a few times, so this seems to be the only way... :-P * * *
533 outHFile = outBase++"_hsc.h"
534 outHName = outDir++outHFile
535 outCName = outDir++outBase++"_hsc.c"
537 beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
540 | null outDir = dosifyPath ("./" ++ progName)
541 | otherwise = progName
543 let specials = [(pos, key, arg) | Special pos key arg <- toks]
545 let needsC = any (\(_, key, _) -> key == "def") specials
548 let includeGuard = map fixChar outHName
550 fixChar c | isAlphaNum c = toUpper c
553 -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
554 -- Returns a native-format path
556 mb <- getExecDir "bin/hsc2hs.exe"
558 Nothing -> return def
560 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
561 flg <- doesFileExist ghc_path
566 -- On a Win32 installation we execute the hsc2hs binary directly,
567 -- with no --cc flags, so we'll call locateGhc here, which will
568 -- succeed, via getExecDir.
570 -- On a Unix installation, we'll run the wrapper script hsc2hs.sh
571 -- (called plain hsc2hs in the installed tree), which will pass
572 -- a suitable C compiler via --cc
574 -- The in-place installation always uses the wrapper script,
575 -- (called hsc2hs-inplace, generated from hsc2hs.sh)
576 compiler <- case [c | Compiler c <- flags] of
577 [] -> locateGhc "ghc"
578 cs -> return (last cs)
580 linker <- case [l | Linker l <- flags] of
581 [] -> locateGhc compiler
583 _ -> onlyOne "linker"
585 writeFile cProgName $
586 concatMap outFlagHeaderCProg flags++
587 concatMap outHeaderCProg specials++
588 "\nint main (int argc, char *argv [])\n{\n"++
589 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
590 outHsLine (SourcePos name 0)++
591 concatMap outTokenHs toks++
594 -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
595 -- so we use something slightly more complicated. :-P
596 when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
599 rawSystemL ("compiling " ++ cProgName) beVerbose compiler
601 ++ [f | CompFlag f <- flags]
605 finallyRemove cProgName $ do
607 rawSystemL ("linking " ++ oProgName) beVerbose linker
608 ( [f | LinkFlag f <- flags]
612 finallyRemove oProgName $ do
614 rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
615 finallyRemove progName $ do
617 when needsH $ writeFile outHName $
618 "#ifndef "++includeGuard++"\n" ++
619 "#define "++includeGuard++"\n" ++
620 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
621 "#include <Rts.h>\n" ++
623 "#include <HsFFI.h>\n" ++
626 "#define HsChar int\n" ++
628 concatMap outFlagH flags++
629 concatMap outTokenH specials++
632 when needsC $ writeFile outCName $
633 "#include \""++outHFile++"\"\n"++
634 concatMap outTokenC specials
635 -- NB. outHFile not outHName; works better when processed
636 -- by gcc or mkdependC.
638 rawSystemL :: String -> Bool -> FilePath -> [String] -> IO ()
639 rawSystemL action flg prog args = do
640 let cmdLine = prog++" "++unwords args
641 when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
642 #ifndef HAVE_rawSystem
643 exitStatus <- system cmdLine
645 exitStatus <- rawSystem prog args
648 ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
651 rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath -> IO ()
652 rawSystemWithStdOutL action flg prog args outFile = do
653 let cmdLine = prog++" "++unwords args++" >"++outFile
654 when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
655 #ifndef HAVE_runProcess
656 exitStatus <- system cmdLine
658 hOut <- openFile outFile WriteMode
659 process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
660 exitStatus <- waitForProcess process
664 ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
668 -- delay the cleanup of generated files until the end; attempts to
669 -- get around intermittent failure to delete files which has
670 -- just been exec'ed by a sub-process (Win32 only.)
671 finallyRemove :: FilePath -> IO a -> IO a
672 finallyRemove fp act =
674 (const $ noisyRemove fp)
678 catch (removeFile fpath)
679 (\ e -> hPutStrLn stderr ("Failed to remove file " ++ fpath ++ "; error= " ++ show e))
680 onlyOne :: String -> IO a
681 onlyOne what = die ("Only one "++what++" may be specified\n")
683 outFlagHeaderCProg :: Flag -> String
684 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
685 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
686 outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n"
687 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
688 outFlagHeaderCProg _ = ""
690 outHeaderCProg :: (SourcePos, String, String) -> String
691 outHeaderCProg (pos, key, arg) = case key of
692 "include" -> outCLine pos++"#include "++arg++"\n"
693 "define" -> outCLine pos++"#define "++arg++"\n"
694 "undef" -> outCLine pos++"#undef "++arg++"\n"
696 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
697 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
699 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
700 "let" -> case break (== '=') arg of
702 (header, _:body) -> case break isSpace header of
705 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
706 "printf ("++joinLines body++");\n"
709 joinLines = concat . intersperse " \\\n" . lines
711 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
712 outHeaderHs flags inH toks =
714 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
715 " printf (\"{-# OPTIONS -optc-D" ++
716 "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
717 "__GLASGOW_HASKELL__);\n" ++
720 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
721 Just f -> outInclude ("\""++f++"\"")
723 outFlag (Include f) = outInclude f
724 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
725 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
727 outSpecial (pos, key, arg) = case key of
728 "include" -> outInclude arg
729 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
731 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
733 goodForOptD arg = case arg of
735 c:_ | isSpace c -> True
738 toOptD arg = case break isSpace arg of
740 (name, _:value) -> name++'=':dropWhile isSpace value
742 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
743 " printf (\"{-# OPTIONS %s #-}\\n\", \""++
744 showCString s++"\");\n"++
746 " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
747 showCString s++"\");\n"++
750 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
751 " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++
752 showCString s++"\");\n"++
754 " printf (\"{-# INCLUDE %s #-}\\n\", \""++
755 showCString s++"\");\n"++
758 outTokenHs :: Token -> String
759 outTokenHs (Text pos txt) =
760 case break (== '\n') txt of
761 (allTxt, []) -> outText allTxt
763 outText (first++"\n")++
767 outText s = " fputs (\""++showCString s++"\", stdout);\n"
768 outTokenHs (Special pos key arg) =
774 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
776 "enum" -> outCLine pos++outEnum arg
777 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
779 outEnum :: String -> String
781 case break (== ',') arg of
783 (t, _:afterT) -> case break (== ',') afterT of
786 enums (_:s) = case break (== ',') s of
788 this = case break (== '=') $ dropWhile isSpace enum of
790 " hsc_enum ("++t++", "++f++", " ++
791 "hsc_haskellize (\""++name++"\"), "++
794 " hsc_enum ("++t++", "++f++", " ++
795 "printf (\"%s\", \""++hsName++"\"), "++
800 outFlagH :: Flag -> String
801 outFlagH (Include f) = "#include "++f++"\n"
802 outFlagH (Define n Nothing) = "#define "++n++" 1\n"
803 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
806 outTokenH :: (SourcePos, String, String) -> String
807 outTokenH (pos, key, arg) =
809 "include" -> outCLine pos++"#include "++arg++"\n"
810 "define" -> outCLine pos++"#define " ++arg++"\n"
811 "undef" -> outCLine pos++"#undef " ++arg++"\n"
812 "def" -> outCLine pos++case arg of
813 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
814 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
815 'i':'n':'l':'i':'n':'e':' ':_ ->
816 "#ifdef __GNUC__\n" ++
820 _ -> "extern "++header++";\n"
821 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
822 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
825 outTokenC :: (SourcePos, String, String) -> String
826 outTokenC (pos, key, arg) =
829 's':'t':'r':'u':'c':'t':' ':_ -> ""
830 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
831 'i':'n':'l':'i':'n':'e':' ':arg' ->
832 case span (\c -> c /= '{' && c /= '=') arg' of
835 "#ifndef __GNUC__\n" ++
839 "\n#ifndef __GNUC__\n" ++
844 _ -> outCLine pos++arg++"\n"
845 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
848 conditional :: String -> Bool
849 conditional "if" = True
850 conditional "ifdef" = True
851 conditional "ifndef" = True
852 conditional "elif" = True
853 conditional "else" = True
854 conditional "endif" = True
855 conditional "error" = True
856 conditional "warning" = True
857 conditional _ = False
859 outCLine :: SourcePos -> String
860 outCLine (SourcePos name line) =
861 "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
863 outHsLine :: SourcePos -> String
864 outHsLine (SourcePos name line) =
865 " hsc_line ("++show (line + 1)++", \""++
866 showCString name++"\");\n"
868 showCString :: String -> String
869 showCString = concatMap showCChar
871 showCChar '\"' = "\\\""
872 showCChar '\'' = "\\\'"
873 showCChar '?' = "\\?"
874 showCChar '\\' = "\\\\"
875 showCChar c | c >= ' ' && c <= '~' = [c]
876 showCChar '\a' = "\\a"
877 showCChar '\b' = "\\b"
878 showCChar '\f' = "\\f"
879 showCChar '\n' = "\\n\"\n \""
880 showCChar '\r' = "\\r"
881 showCChar '\t' = "\\t"
882 showCChar '\v' = "\\v"
884 intToDigit (ord c `quot` 64),
885 intToDigit (ord c `quot` 8 `mod` 8),
886 intToDigit (ord c `mod` 8)]
888 -----------------------------------------
889 -- Modified version from ghc/compiler/SysTools
890 -- Convert paths foo/baz to foo\baz on Windows
892 subst :: Char -> Char -> String -> String
893 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
894 subst a b = map (\x -> if x == a then b else x)
899 dosifyPath :: String -> String
900 dosifyPath = subst '/' '\\'
902 -- (getExecDir cmd) returns the directory in which the current
903 -- executable, which should be called 'cmd', is running
904 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
905 -- you'll get "/a/b/c" back as the result
906 getExecDir :: String -> IO (Maybe String)
908 getExecPath >>= maybe (return Nothing) removeCmdSuffix
909 where unDosifyPath = subst '\\' '/'
910 initN n = reverse . drop n . reverse
911 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
913 getExecPath :: IO (Maybe String)
914 #if defined(mingw32_HOST_OS)
916 allocaArray len $ \buf -> do
917 ret <- getModuleFileName nullPtr buf len
918 if ret == 0 then return Nothing
919 else liftM Just $ peekCString buf
920 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
922 foreign import stdcall unsafe "GetModuleFileNameA"
923 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
925 getExecPath = return Nothing