use runProcess instead of system if appropriate
[hsc2hs.git] / Main.hs
1 {-# OPTIONS -fffi -cpp #-}
2
3 ------------------------------------------------------------------------
4 -- $Id: Main.hs,v 1.73 2005/05/17 09:48:27 krasimir Exp $
5 --
6 -- Program for converting .hsc files to .hs files, by converting the
7 -- file into a C program which is run to generate the Haskell source.
8 -- Certain items known only to the C compiler can then be used in
9 -- the Haskell module; for example #defined constants, byte offsets
10 -- within structures, etc.
11 --
12 -- See the documentation in the Users' Guide for more details.
13
14 #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
15 #include "../../includes/ghcconfig.h"
16 #endif
17
18 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114 || __HUGS__
19 import System.Console.GetOpt
20 #else
21 import GetOpt
22 #endif
23
24 import System (getProgName, getArgs, ExitCode(..), exitWith)
25 import Directory (removeFile,doesFileExist)
26 import Monad (MonadPlus(..), liftM, liftM2, when)
27 import Char (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
28 import List (intersperse, isSuffixOf)
29 import IO (hPutStr, hPutStrLn, stderr)
30
31 #if defined(mingw32_HOST_OS) && !__HUGS__
32 import Foreign
33 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
34 import Foreign.C.String
35 #else
36 import CString
37 #endif
38 #endif
39
40
41 #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
42
43 import Compat.RawSystem ( rawSystem )
44 import System.Process ( runProcess, waitForProcess )
45 import System.IO ( openFile, IOMode(..), hClose )
46 #define HAVE_rawSystem
47 #define HAVE_runProcess
48
49 #elif __HUGS__ || __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600
50
51 import System.Cmd ( system, rawSystem )
52 #define HAVE_rawSystem
53
54 #else
55
56 import System ( system )
57
58 #endif
59
60 version :: String
61 version = "hsc2hs version 0.66\n"
62
63 data Flag
64 = Help
65 | Version
66 | Template String
67 | Compiler String
68 | Linker String
69 | CompFlag String
70 | LinkFlag String
71 | NoCompile
72 | Include String
73 | Define String (Maybe String)
74 | Output String
75 | Verbose
76
77 template_flag :: Flag -> Bool
78 template_flag (Template _) = True
79 template_flag _ = False
80
81 include :: String -> Flag
82 include s@('\"':_) = Include s
83 include s@('<' :_) = Include s
84 include s = Include ("\""++s++"\"")
85
86 define :: String -> Flag
87 define s = case break (== '=') s of
88 (name, []) -> Define name Nothing
89 (name, _:value) -> Define name (Just value)
90
91 options :: [OptDescr Flag]
92 options = [
93 Option ['o'] ["output"] (ReqArg Output "FILE")
94 "name of main output file",
95 Option ['t'] ["template"] (ReqArg Template "FILE")
96 "template file",
97 Option ['c'] ["cc"] (ReqArg Compiler "PROG")
98 "C compiler to use",
99 Option ['l'] ["ld"] (ReqArg Linker "PROG")
100 "linker to use",
101 Option ['C'] ["cflag"] (ReqArg CompFlag "FLAG")
102 "flag to pass to the C compiler",
103 Option ['I'] [] (ReqArg (CompFlag . ("-I"++)) "DIR")
104 "passed to the C compiler",
105 Option ['L'] ["lflag"] (ReqArg LinkFlag "FLAG")
106 "flag to pass to the linker",
107 Option ['i'] ["include"] (ReqArg include "FILE")
108 "as if placed in the source",
109 Option ['D'] ["define"] (ReqArg define "NAME[=VALUE]")
110 "as if placed in the source",
111 Option [] ["no-compile"] (NoArg NoCompile)
112 "stop after writing *_hsc_make.c",
113 Option ['v'] ["verbose"] (NoArg Verbose)
114 "dump commands to stderr",
115 Option ['?'] ["help"] (NoArg Help)
116 "display this help and exit",
117 Option ['V'] ["version"] (NoArg Version)
118 "output version information and exit" ]
119
120
121 main :: IO ()
122 main = do
123 prog <- getProgramName
124 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
125 args <- getArgs
126 let (flags, files, errs) = getOpt Permute options args
127
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_tpl <- if any template_flag flags then
133 return flags
134 else
135 #ifdef __HUGS__
136 do mb_path <- getExecDir "/Main.hs"
137 #else
138 do mb_path <- getExecDir "/bin/hsc2hs.exe"
139 #endif
140 add_opt <-
141 case mb_path of
142 Nothing -> return id
143 Just path -> do
144 let templ = path ++ "/template-hsc.h"
145 flg <- doesFileExist templ
146 if flg
147 then return ((Template templ):)
148 else return id
149 return (add_opt flags)
150 case (files, errs) of
151 (_, _)
152 | any isHelp flags_w_tpl -> bye (usageInfo header options)
153 | any isVersion flags_w_tpl -> bye version
154 where
155 isHelp Help = True; isHelp _ = False
156 isVersion Version = True; isVersion _ = False
157 ((_:_), []) -> mapM_ (processFile flags_w_tpl) files
158 (_, _ ) -> die (concat errs ++ usageInfo header options)
159
160 getProgramName :: IO String
161 getProgramName = liftM (`withoutSuffix` "-bin") getProgName
162 where str `withoutSuffix` suff
163 | suff `isSuffixOf` str = take (length str - length suff) str
164 | otherwise = str
165
166 bye :: String -> IO a
167 bye s = putStr s >> exitWith ExitSuccess
168
169 die :: String -> IO a
170 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
171
172 processFile :: [Flag] -> String -> IO ()
173 processFile flags name
174 = do let file_name = dosifyPath name
175 s <- readFile file_name
176 case parser of
177 Parser p -> case p (SourcePos file_name 1) s of
178 Success _ _ _ toks -> output flags file_name toks
179 Failure (SourcePos name' line) msg ->
180 die (name'++":"++show line++": "++msg++"\n")
181
182 ------------------------------------------------------------------------
183 -- A deterministic parser which remembers the text which has been parsed.
184
185 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
186
187 data ParseResult a = Success !SourcePos String String a
188 | Failure !SourcePos String
189
190 data SourcePos = SourcePos String !Int
191
192 updatePos :: SourcePos -> Char -> SourcePos
193 updatePos pos@(SourcePos name line) ch = case ch of
194 '\n' -> SourcePos name (line + 1)
195 _ -> pos
196
197 instance Monad Parser where
198 return a = Parser $ \pos s -> Success pos [] s a
199 Parser m >>= k =
200 Parser $ \pos s -> case m pos s of
201 Success pos' out1 s' a -> case k a of
202 Parser k' -> case k' pos' s' of
203 Success pos'' out2 imp'' b ->
204 Success pos'' (out1++out2) imp'' b
205 Failure pos'' msg -> Failure pos'' msg
206 Failure pos' msg -> Failure pos' msg
207 fail msg = Parser $ \pos _ -> Failure pos msg
208
209 instance MonadPlus Parser where
210 mzero = fail "mzero"
211 Parser m `mplus` Parser n =
212 Parser $ \pos s -> case m pos s of
213 success@(Success _ _ _ _) -> success
214 Failure _ _ -> n pos s
215
216 getPos :: Parser SourcePos
217 getPos = Parser $ \pos s -> Success pos [] s pos
218
219 setPos :: SourcePos -> Parser ()
220 setPos pos = Parser $ \_ s -> Success pos [] s ()
221
222 message :: Parser a -> String -> Parser a
223 Parser m `message` msg =
224 Parser $ \pos s -> case m pos s of
225 success@(Success _ _ _ _) -> success
226 Failure pos' _ -> Failure pos' msg
227
228 catchOutput_ :: Parser a -> Parser String
229 catchOutput_ (Parser m) =
230 Parser $ \pos s -> case m pos s of
231 Success pos' out s' _ -> Success pos' [] s' out
232 Failure pos' msg -> Failure pos' msg
233
234 fakeOutput :: Parser a -> String -> Parser a
235 Parser m `fakeOutput` out =
236 Parser $ \pos s -> case m pos s of
237 Success pos' _ s' a -> Success pos' out s' a
238 Failure pos' msg -> Failure pos' msg
239
240 lookAhead :: Parser String
241 lookAhead = Parser $ \pos s -> Success pos [] s s
242
243 satisfy :: (Char -> Bool) -> Parser Char
244 satisfy p =
245 Parser $ \pos s -> case s of
246 c:cs | p c -> Success (updatePos pos c) [c] cs c
247 _ -> Failure pos "Bad character"
248
249 char_ :: Char -> Parser ()
250 char_ c = do
251 satisfy (== c) `message` (show c++" expected")
252 return ()
253
254 anyChar_ :: Parser ()
255 anyChar_ = do
256 satisfy (const True) `message` "Unexpected end of file"
257 return ()
258
259 any2Chars_ :: Parser ()
260 any2Chars_ = anyChar_ >> anyChar_
261
262 many :: Parser a -> Parser [a]
263 many p = many1 p `mplus` return []
264
265 many1 :: Parser a -> Parser [a]
266 many1 p = liftM2 (:) p (many p)
267
268 many_ :: Parser a -> Parser ()
269 many_ p = many1_ p `mplus` return ()
270
271 many1_ :: Parser a -> Parser ()
272 many1_ p = p >> many_ p
273
274 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
275 manySatisfy = many . satisfy
276 manySatisfy1 = many1 . satisfy
277
278 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
279 manySatisfy_ = many_ . satisfy
280 manySatisfy1_ = many1_ . satisfy
281
282 ------------------------------------------------------------------------
283 -- Parser of hsc syntax.
284
285 data Token
286 = Text SourcePos String
287 | Special SourcePos String String
288
289 parser :: Parser [Token]
290 parser = do
291 pos <- getPos
292 t <- catchOutput_ text
293 s <- lookAhead
294 rest <- case s of
295 [] -> return []
296 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
297 return (if null t then rest else Text pos t : rest)
298
299 text :: Parser ()
300 text = do
301 s <- lookAhead
302 case s of
303 [] -> return ()
304 c:_ | isAlpha c || c == '_' -> do
305 anyChar_
306 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
307 text
308 c:_ | isHsSymbol c -> do
309 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
310 case symb of
311 "#" -> return ()
312 '-':'-':symb' | all (== '-') symb' -> do
313 return () `fakeOutput` symb
314 manySatisfy_ (/= '\n')
315 text
316 _ -> do
317 return () `fakeOutput` unescapeHashes symb
318 text
319 '\"':_ -> do anyChar_; hsString '\"'; text
320 '\'':_ -> do anyChar_; hsString '\''; text
321 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
322 _:_ -> do anyChar_; text
323
324 hsString :: Char -> Parser ()
325 hsString quote = do
326 s <- lookAhead
327 case s of
328 [] -> return ()
329 c:_ | c == quote -> anyChar_
330 '\\':c:_
331 | isSpace c -> do
332 anyChar_
333 manySatisfy_ isSpace
334 char_ '\\' `mplus` return ()
335 hsString quote
336 | otherwise -> do any2Chars_; hsString quote
337 _:_ -> do anyChar_; hsString quote
338
339 hsComment :: Parser ()
340 hsComment = do
341 s <- lookAhead
342 case s of
343 [] -> return ()
344 '-':'}':_ -> any2Chars_
345 '{':'-':_ -> do any2Chars_; hsComment; hsComment
346 _:_ -> do anyChar_; hsComment
347
348 linePragma :: Parser ()
349 linePragma = do
350 char_ '#'
351 manySatisfy_ isSpace
352 satisfy (\c -> c == 'L' || c == 'l')
353 satisfy (\c -> c == 'I' || c == 'i')
354 satisfy (\c -> c == 'N' || c == 'n')
355 satisfy (\c -> c == 'E' || c == 'e')
356 manySatisfy1_ isSpace
357 line <- liftM read $ manySatisfy1 isDigit
358 manySatisfy1_ isSpace
359 char_ '\"'
360 name <- manySatisfy (/= '\"')
361 char_ '\"'
362 manySatisfy_ isSpace
363 char_ '#'
364 char_ '-'
365 char_ '}'
366 setPos (SourcePos name (line - 1))
367
368 isHsSymbol :: Char -> Bool
369 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True
370 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True
371 isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True
372 isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True
373 isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True
374 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True
375 isHsSymbol '~' = True
376 isHsSymbol _ = False
377
378 unescapeHashes :: String -> String
379 unescapeHashes [] = []
380 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
381 unescapeHashes (c:s) = c : unescapeHashes s
382
383 lookAheadC :: Parser String
384 lookAheadC = liftM joinLines lookAhead
385 where
386 joinLines [] = []
387 joinLines ('\\':'\n':s) = joinLines s
388 joinLines (c:s) = c : joinLines s
389
390 satisfyC :: (Char -> Bool) -> Parser Char
391 satisfyC p = do
392 s <- lookAhead
393 case s of
394 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
395 _ -> satisfy p
396
397 charC_ :: Char -> Parser ()
398 charC_ c = do
399 satisfyC (== c) `message` (show c++" expected")
400 return ()
401
402 anyCharC_ :: Parser ()
403 anyCharC_ = do
404 satisfyC (const True) `message` "Unexpected end of file"
405 return ()
406
407 any2CharsC_ :: Parser ()
408 any2CharsC_ = anyCharC_ >> anyCharC_
409
410 manySatisfyC :: (Char -> Bool) -> Parser String
411 manySatisfyC = many . satisfyC
412
413 manySatisfyC_ :: (Char -> Bool) -> Parser ()
414 manySatisfyC_ = many_ . satisfyC
415
416 special :: Parser Token
417 special = do
418 manySatisfyC_ (\c -> isSpace c && c /= '\n')
419 s <- lookAheadC
420 case s of
421 '{':_ -> do
422 anyCharC_
423 manySatisfyC_ isSpace
424 sp <- keyArg (== '\n')
425 charC_ '}'
426 return sp
427 _ -> keyArg (const False)
428
429 keyArg :: (Char -> Bool) -> Parser Token
430 keyArg eol = do
431 pos <- getPos
432 key <- keyword `message` "hsc keyword or '{' expected"
433 manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
434 arg <- catchOutput_ (argument eol)
435 return (Special pos key arg)
436
437 keyword :: Parser String
438 keyword = do
439 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
440 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
441 return (c:cs)
442
443 argument :: (Char -> Bool) -> Parser ()
444 argument eol = do
445 s <- lookAheadC
446 case s of
447 [] -> return ()
448 c:_ | eol c -> do anyCharC_; argument eol
449 '\n':_ -> return ()
450 '\"':_ -> do anyCharC_; cString '\"'; argument eol
451 '\'':_ -> do anyCharC_; cString '\''; argument eol
452 '(':_ -> do anyCharC_; nested ')'; argument eol
453 ')':_ -> return ()
454 '/':'*':_ -> do any2CharsC_; cComment; argument eol
455 '/':'/':_ -> do
456 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
457 '[':_ -> do anyCharC_; nested ']'; argument eol
458 ']':_ -> return ()
459 '{':_ -> do anyCharC_; nested '}'; argument eol
460 '}':_ -> return ()
461 _:_ -> do anyCharC_; argument eol
462
463 nested :: Char -> Parser ()
464 nested c = do argument (== '\n'); charC_ c
465
466 cComment :: Parser ()
467 cComment = do
468 s <- lookAheadC
469 case s of
470 [] -> return ()
471 '*':'/':_ -> do any2CharsC_
472 _:_ -> do anyCharC_; cComment
473
474 cString :: Char -> Parser ()
475 cString quote = do
476 s <- lookAheadC
477 case s of
478 [] -> return ()
479 c:_ | c == quote -> anyCharC_
480 '\\':_:_ -> do any2CharsC_; cString quote
481 _:_ -> do anyCharC_; cString quote
482
483 ------------------------------------------------------------------------
484 -- Write the output files.
485
486 splitName :: String -> (String, String)
487 splitName name =
488 case break (== '/') name of
489 (file, []) -> ([], file)
490 (dir, sep:rest) -> (dir++sep:restDir, restFile)
491 where
492 (restDir, restFile) = splitName rest
493
494 splitExt :: String -> (String, String)
495 splitExt name =
496 case break (== '.') name of
497 (base, []) -> (base, [])
498 (base, sepRest@(sep:rest))
499 | null restExt -> (base, sepRest)
500 | otherwise -> (base++sep:restBase, restExt)
501 where
502 (restBase, restExt) = splitExt rest
503
504 output :: [Flag] -> String -> [Token] -> IO ()
505 output flags name toks = do
506
507 (outName, outDir, outBase) <- case [f | Output f <- flags] of
508 [] -> if not (null ext) && last ext == 'c'
509 then return (dir++base++init ext, dir, base)
510 else
511 if ext == ".hs"
512 then return (dir++base++"_out.hs", dir, base)
513 else return (dir++base++".hs", dir, base)
514 where
515 (dir, file) = splitName name
516 (base, ext) = splitExt file
517 [f] -> let
518 (dir, file) = splitName f
519 (base, _) = splitExt file
520 in return (f, dir, base)
521 _ -> onlyOne "output file"
522
523 let cProgName = outDir++outBase++"_hsc_make.c"
524 oProgName = outDir++outBase++"_hsc_make.o"
525 progName = outDir++outBase++"_hsc_make"
526 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
527 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
528 -- via GHC has changed a few times, so this seems to be the only way... :-P * * *
529 ++ ".exe"
530 #endif
531 outHFile = outBase++"_hsc.h"
532 outHName = outDir++outHFile
533 outCName = outDir++outBase++"_hsc.c"
534
535 beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
536
537 let execProgName
538 | null outDir = dosifyPath ("./" ++ progName)
539 | otherwise = progName
540
541 let specials = [(pos, key, arg) | Special pos key arg <- toks]
542
543 let needsC = any (\(_, key, _) -> key == "def") specials
544 needsH = needsC
545
546 let includeGuard = map fixChar outHName
547 where
548 fixChar c | isAlphaNum c = toUpper c
549 | otherwise = '_'
550
551 #ifdef __HUGS__
552 compiler <- case [c | Compiler c <- flags] of
553 [] -> return "gcc"
554 [c] -> return c
555 _ -> onlyOne "compiler"
556
557 linker <- case [l | Linker l <- flags] of
558 [] -> return compiler
559 [l] -> return l
560 _ -> onlyOne "linker"
561 #else
562 -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
563 -- Returns a native-format path
564 locateGhc def = do
565 mb <- getExecDir "bin/hsc2hs.exe"
566 case mb of
567 Nothing -> return def
568 Just x -> do
569 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
570 flg <- doesFileExist ghc_path
571 if flg
572 then return ghc_path
573 else return def
574
575 -- On a Win32 installation we execute the hsc2hs binary directly,
576 -- with no --cc flags, so we'll call locateGhc here, which will
577 -- succeed, via getExecDir.
578 --
579 -- On a Unix installation, we'll run the wrapper script hsc2hs.sh
580 -- (called plain hsc2hs in the installed tree), which will pass
581 -- a suitable C compiler via --cc
582 --
583 -- The in-place installation always uses the wrapper script,
584 -- (called hsc2hs-inplace, generated from hsc2hs.sh)
585 compiler <- case [c | Compiler c <- flags] of
586 [] -> locateGhc "ghc"
587 [c] -> return c
588 _ -> onlyOne "compiler"
589
590 linker <- case [l | Linker l <- flags] of
591 [] -> locateGhc compiler
592 [l] -> return l
593 _ -> onlyOne "linker"
594 #endif
595
596 writeFile cProgName $
597 concatMap outFlagHeaderCProg flags++
598 concatMap outHeaderCProg specials++
599 "\nint main (int argc, char *argv [])\n{\n"++
600 outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
601 outHsLine (SourcePos name 0)++
602 concatMap outTokenHs toks++
603 " return 0;\n}\n"
604
605 -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
606 -- so we use something slightly more complicated. :-P
607 when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
608 exitWith ExitSuccess
609
610
611
612 compilerStatus <- rawSystemL beVerbose compiler
613 ( ["-c"]
614 ++ [f | CompFlag f <- flags]
615 ++ [cProgName]
616 ++ ["-o", oProgName]
617 )
618
619 case compilerStatus of
620 e@(ExitFailure _) -> exitWith e
621 _ -> return ()
622 removeFile cProgName
623
624 linkerStatus <- rawSystemL beVerbose linker
625 ( [f | LinkFlag f <- flags]
626 ++ [oProgName]
627 ++ ["-o", progName]
628 )
629
630 case linkerStatus of
631 e@(ExitFailure _) -> exitWith e
632 _ -> return ()
633 removeFile oProgName
634
635 progStatus <- rawSystemWithStdOutL beVerbose execProgName [] outName
636 removeFile progName
637 case progStatus of
638 e@(ExitFailure _) -> exitWith e
639 _ -> return ()
640
641 when needsH $ writeFile outHName $
642 "#ifndef "++includeGuard++"\n" ++
643 "#define "++includeGuard++"\n" ++
644 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
645 "#include <Rts.h>\n" ++
646 "#endif\n" ++
647 "#include <HsFFI.h>\n" ++
648 "#if __NHC__\n" ++
649 "#undef HsChar\n" ++
650 "#define HsChar int\n" ++
651 "#endif\n" ++
652 concatMap outFlagH flags++
653 concatMap outTokenH specials++
654 "#endif\n"
655
656 when needsC $ writeFile outCName $
657 "#include \""++outHFile++"\"\n"++
658 concatMap outTokenC specials
659 -- NB. outHFile not outHName; works better when processed
660 -- by gcc or mkdependC.
661
662 rawSystemL :: Bool -> FilePath -> [String] -> IO ExitCode
663 rawSystemL flg prog args = do
664 let cmdLine = prog++" "++unwords args
665 when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine)
666 #ifndef HAVE_rawSystem
667 system cmdLine
668 #else
669 rawSystem prog args
670 #endif
671
672 rawSystemWithStdOutL :: Bool -> FilePath -> [String] -> FilePath -> IO ExitCode
673 rawSystemWithStdOutL flg prog args outFile = do
674 let cmdLine = prog++" "++unwords args++" >"++outFile
675 when flg (hPutStrLn stderr ("Executing: " ++ cmdLine))
676 #ifndef HAVE_runProcess
677 system cmdLine
678 #else
679 hOut <- openFile outFile WriteMode
680 process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
681 res <- waitForProcess process
682 hClose hOut
683 return res
684 #endif
685
686 onlyOne :: String -> IO a
687 onlyOne what = die ("Only one "++what++" may be specified\n")
688
689 outFlagHeaderCProg :: Flag -> String
690 outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n"
691 outFlagHeaderCProg (Include f) = "#include "++f++"\n"
692 outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n"
693 outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n"
694 outFlagHeaderCProg _ = ""
695
696 outHeaderCProg :: (SourcePos, String, String) -> String
697 outHeaderCProg (pos, key, arg) = case key of
698 "include" -> outCLine pos++"#include "++arg++"\n"
699 "define" -> outCLine pos++"#define "++arg++"\n"
700 "undef" -> outCLine pos++"#undef "++arg++"\n"
701 "def" -> case arg of
702 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
703 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
704 _ -> ""
705 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
706 "let" -> case break (== '=') arg of
707 (_, "") -> ""
708 (header, _:body) -> case break isSpace header of
709 (name, args) ->
710 outCLine pos++
711 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
712 "printf ("++joinLines body++");\n"
713 _ -> ""
714 where
715 joinLines = concat . intersperse " \\\n" . lines
716
717 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
718 outHeaderHs flags inH toks =
719 "#if " ++
720 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
721 " printf (\"{-# OPTIONS -optc-D" ++
722 "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
723 "__GLASGOW_HASKELL__);\n" ++
724 "#endif\n"++
725 case inH of
726 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
727 Just f -> outInclude ("\""++f++"\"")
728 where
729 outFlag (Include f) = outInclude f
730 outFlag (Define n Nothing) = outOption ("-optc-D"++n)
731 outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v)
732 outFlag _ = ""
733 outSpecial (pos, key, arg) = case key of
734 "include" -> outInclude arg
735 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
736 | otherwise -> ""
737 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
738 _ -> ""
739 goodForOptD arg = case arg of
740 "" -> True
741 c:_ | isSpace c -> True
742 '(':_ -> False
743 _:s -> goodForOptD s
744 toOptD arg = case break isSpace arg of
745 (name, "") -> name
746 (name, _:value) -> name++'=':dropWhile isSpace value
747 outOption s =
748 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
749 " printf (\"{-# OPTIONS %s #-}\\n\", \""++
750 showCString s++"\");\n"++
751 "#else\n"++
752 " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
753 showCString s++"\");\n"++
754 "#endif\n"
755 outInclude s =
756 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
757 " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++
758 showCString s++"\");\n"++
759 "#else\n"++
760 " printf (\"{-# INCLUDE %s #-}\\n\", \""++
761 showCString s++"\");\n"++
762 "#endif\n"
763
764 outTokenHs :: Token -> String
765 outTokenHs (Text pos txt) =
766 case break (== '\n') txt of
767 (allTxt, []) -> outText allTxt
768 (first, _:rest) ->
769 outText (first++"\n")++
770 outHsLine pos++
771 outText rest
772 where
773 outText s = " fputs (\""++showCString s++"\", stdout);\n"
774 outTokenHs (Special pos key arg) =
775 case key of
776 "include" -> ""
777 "define" -> ""
778 "undef" -> ""
779 "def" -> ""
780 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
781 "let" -> ""
782 "enum" -> outCLine pos++outEnum arg
783 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
784
785 outEnum :: String -> String
786 outEnum arg =
787 case break (== ',') arg of
788 (_, []) -> ""
789 (t, _:afterT) -> case break (== ',') afterT of
790 (f, afterF) -> let
791 enums [] = ""
792 enums (_:s) = case break (== ',') s of
793 (enum, rest) -> let
794 this = case break (== '=') $ dropWhile isSpace enum of
795 (name, []) ->
796 " hsc_enum ("++t++", "++f++", " ++
797 "hsc_haskellize (\""++name++"\"), "++
798 name++");\n"
799 (hsName, _:cName) ->
800 " hsc_enum ("++t++", "++f++", " ++
801 "printf (\"%s\", \""++hsName++"\"), "++
802 cName++");\n"
803 in this++enums rest
804 in enums afterF
805
806 outFlagH :: Flag -> String
807 outFlagH (Include f) = "#include "++f++"\n"
808 outFlagH (Define n Nothing) = "#define "++n++" 1\n"
809 outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n"
810 outFlagH _ = ""
811
812 outTokenH :: (SourcePos, String, String) -> String
813 outTokenH (pos, key, arg) =
814 case key of
815 "include" -> outCLine pos++"#include "++arg++"\n"
816 "define" -> outCLine pos++"#define " ++arg++"\n"
817 "undef" -> outCLine pos++"#undef " ++arg++"\n"
818 "def" -> outCLine pos++case arg of
819 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
820 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
821 'i':'n':'l':'i':'n':'e':' ':_ ->
822 "#ifdef __GNUC__\n" ++
823 "extern\n" ++
824 "#endif\n"++
825 arg++"\n"
826 _ -> "extern "++header++";\n"
827 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
828 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
829 _ -> ""
830
831 outTokenC :: (SourcePos, String, String) -> String
832 outTokenC (pos, key, arg) =
833 case key of
834 "def" -> case arg of
835 's':'t':'r':'u':'c':'t':' ':_ -> ""
836 't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
837 'i':'n':'l':'i':'n':'e':' ':arg' ->
838 case span (\c -> c /= '{' && c /= '=') arg' of
839 (header, body) ->
840 outCLine pos++
841 "#ifndef __GNUC__\n" ++
842 "extern inline\n" ++
843 "#endif\n"++
844 header++
845 "\n#ifndef __GNUC__\n" ++
846 ";\n" ++
847 "#else\n"++
848 body++
849 "\n#endif\n"
850 _ -> outCLine pos++arg++"\n"
851 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
852 _ -> ""
853
854 conditional :: String -> Bool
855 conditional "if" = True
856 conditional "ifdef" = True
857 conditional "ifndef" = True
858 conditional "elif" = True
859 conditional "else" = True
860 conditional "endif" = True
861 conditional "error" = True
862 conditional "warning" = True
863 conditional _ = False
864
865 outCLine :: SourcePos -> String
866 outCLine (SourcePos name line) =
867 "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
868
869 outHsLine :: SourcePos -> String
870 outHsLine (SourcePos name line) =
871 " hsc_line ("++show (line + 1)++", \""++
872 showCString (snd (splitName name))++"\");\n"
873
874 showCString :: String -> String
875 showCString = concatMap showCChar
876 where
877 showCChar '\"' = "\\\""
878 showCChar '\'' = "\\\'"
879 showCChar '?' = "\\?"
880 showCChar '\\' = "\\\\"
881 showCChar c | c >= ' ' && c <= '~' = [c]
882 showCChar '\a' = "\\a"
883 showCChar '\b' = "\\b"
884 showCChar '\f' = "\\f"
885 showCChar '\n' = "\\n\"\n \""
886 showCChar '\r' = "\\r"
887 showCChar '\t' = "\\t"
888 showCChar '\v' = "\\v"
889 showCChar c = ['\\',
890 intToDigit (ord c `quot` 64),
891 intToDigit (ord c `quot` 8 `mod` 8),
892 intToDigit (ord c `mod` 8)]
893
894
895
896 -----------------------------------------
897 -- Cut and pasted from ghc/compiler/SysTools
898 -- Convert paths foo/baz to foo\baz on Windows
899
900 dosifyPath, unDosifyPath :: String -> String
901 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
902 dosifyPath xs = subst '/' '\\' xs
903 unDosifyPath xs = subst '\\' '/' xs
904
905 subst :: Eq a => a -> a -> [a] -> [a]
906 subst a b ls = map (\ x -> if x == a then b else x) ls
907 #else
908 dosifyPath xs = xs
909 unDosifyPath xs = xs
910 #endif
911
912 getExecDir :: String -> IO (Maybe String)
913 -- (getExecDir cmd) returns the directory in which the current
914 -- executable, which should be called 'cmd', is running
915 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
916 -- you'll get "/a/b/c" back as the result
917 #ifdef __HUGS__
918 getExecDir cmd
919 = do
920 s <- getProgName
921 return (Just (reverse (drop (length cmd) (reverse (unDosifyPath s)))))
922 #elif defined(mingw32_HOST_OS)
923 getExecDir cmd
924 = allocaArray len $ \buf -> do
925 ret <- getModuleFileName nullPtr buf len
926 if ret == 0 then return Nothing
927 else do s <- peekCString buf
928 return (Just (reverse (drop (length cmd)
929 (reverse (unDosifyPath s)))))
930 where
931 len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
932
933 foreign import stdcall unsafe "GetModuleFileNameA"
934 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
935
936 #else
937 getExecDir _ = return Nothing
938 #endif