a5bd774387f04c2f4d90184d2100ecefc633c069
[ghc.git] / utils / hsc2hs / Main.hs
1 {-# OPTIONS -fffi -cpp #-}
2
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.
9 --
10 -- See the documentation in the Users' Guide for more details.
11
12 #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
13 #include "../../includes/ghcconfig.h"
14 #endif
15
16 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
17 import System.Console.GetOpt
18 #else
19 import GetOpt
20 #endif
21
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_)
28
29 #if defined(mingw32_HOST_OS)
30 import Foreign
31 #if __GLASGOW_HASKELL__ >= 504 || __NHC__ >= 114
32 import Foreign.C.String
33 #else
34 import CString
35 #endif
36 #endif
37
38 #if __GLASGOW_HASKELL__ >= 604
39 import System.Process ( runProcess, waitForProcess )
40 import System.IO ( openFile, IOMode(..), hClose )
41 #define HAVE_runProcess
42 #endif
43
44 #if defined(__GLASGOW_HASKELL__) && !defined(BUILD_NHC)
45 #ifdef USING_COMPAT
46 import Compat.RawSystem ( rawSystem )
47 #else
48 import System.Cmd ( rawSystem )
49 #endif
50 #define HAVE_rawSystem
51 #elif __NHC__ >= 117
52 import System.Cmd ( rawSystem )
53 #define HAVE_rawSystem
54 #endif
55
56 #if !defined(HAVE_runProcess) || !defined(HAVE_rawSystem)
57 -- we need system
58 #if __NHC__ >= 117 || __GLASGOW_HASKELL__ >= 600
59 import System.Cmd ( system )
60 #else
61 import System ( system )
62 #endif
63 #endif
64
65 version :: String
66 version = "hsc2hs version 0.66\n"
67
68 data Flag
69 = Help
70 | Version
71 | Template String
72 | Compiler String
73 | Linker String
74 | CompFlag String
75 | LinkFlag String
76 | NoCompile
77 | Include String
78 | Define String (Maybe String)
79 | Output String
80 | Verbose
81
82 template_flag :: Flag -> Bool
83 template_flag (Template _) = True
84 template_flag _ = False
85
86 include :: String -> Flag
87 include s@('\"':_) = Include s
88 include s@('<' :_) = Include s
89 include s = Include ("\""++s++"\"")
90
91 define :: String -> Flag
92 define s = case break (== '=') s of
93 (name, []) -> Define name Nothing
94 (name, _:value) -> Define name (Just value)
95
96 options :: [OptDescr Flag]
97 options = [
98 Option ['o'] ["output"] (ReqArg Output "FILE")
99 "name of main output file",
100 Option ['t'] ["template"] (ReqArg Template "FILE")
101 "template file",
102 Option ['c'] ["cc"] (ReqArg Compiler "PROG")
103 "C compiler to use",
104 Option ['l'] ["ld"] (ReqArg Linker "PROG")
105 "linker to use",
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" ]
124
125 main :: IO ()
126 main = do
127 prog <- getProgramName
128 let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n"
129 args <- getArgs
130 let (flags, files, errs) = getOpt Permute options args
131
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
137 return flags
138 else
139 do mb_path <- getExecDir "/bin/hsc2hs.exe"
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
151 -- take only the last --template flag on the cmd line
152 let
153 (before,tpl:after) = break template_flag (reverse flags_w_tpl0)
154 flags_w_tpl = reverse (before ++ tpl : filter (not.template_flag) after)
155
156 case (files, errs) of
157 (_, _)
158 | any isHelp flags_w_tpl -> bye (usageInfo header options)
159 | any isVersion flags_w_tpl -> bye version
160 where
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)
165
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
170 | otherwise = str
171
172 bye :: String -> IO a
173 bye s = putStr s >> exitWith ExitSuccess
174
175 die :: String -> IO a
176 die s = hPutStr stderr s >> exitWith (ExitFailure 1)
177
178 processFile :: [Flag] -> String -> IO ()
179 processFile flags name
180 = do let file_name = dosifyPath name
181 s <- readFile file_name
182 case parser of
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")
187
188 ------------------------------------------------------------------------
189 -- A deterministic parser which remembers the text which has been parsed.
190
191 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
192
193 data ParseResult a = Success !SourcePos String String a
194 | Failure !SourcePos String
195
196 data SourcePos = SourcePos String !Int
197
198 updatePos :: SourcePos -> Char -> SourcePos
199 updatePos pos@(SourcePos name line) ch = case ch of
200 '\n' -> SourcePos name (line + 1)
201 _ -> pos
202
203 instance Monad Parser where
204 return a = Parser $ \pos s -> Success pos [] s a
205 Parser m >>= k =
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
214
215 instance MonadPlus Parser where
216 mzero = fail "mzero"
217 Parser m `mplus` Parser n =
218 Parser $ \pos s -> case m pos s of
219 success@(Success _ _ _ _) -> success
220 Failure _ _ -> n pos s
221
222 getPos :: Parser SourcePos
223 getPos = Parser $ \pos s -> Success pos [] s pos
224
225 setPos :: SourcePos -> Parser ()
226 setPos pos = Parser $ \_ s -> Success pos [] s ()
227
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
233
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
239
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
245
246 lookAhead :: Parser String
247 lookAhead = Parser $ \pos s -> Success pos [] s s
248
249 satisfy :: (Char -> Bool) -> Parser Char
250 satisfy p =
251 Parser $ \pos s -> case s of
252 c:cs | p c -> Success (updatePos pos c) [c] cs c
253 _ -> Failure pos "Bad character"
254
255 char_ :: Char -> Parser ()
256 char_ c = do
257 satisfy (== c) `message` (show c++" expected")
258 return ()
259
260 anyChar_ :: Parser ()
261 anyChar_ = do
262 satisfy (const True) `message` "Unexpected end of file"
263 return ()
264
265 any2Chars_ :: Parser ()
266 any2Chars_ = anyChar_ >> anyChar_
267
268 many :: Parser a -> Parser [a]
269 many p = many1 p `mplus` return []
270
271 many1 :: Parser a -> Parser [a]
272 many1 p = liftM2 (:) p (many p)
273
274 many_ :: Parser a -> Parser ()
275 many_ p = many1_ p `mplus` return ()
276
277 many1_ :: Parser a -> Parser ()
278 many1_ p = p >> many_ p
279
280 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
281 manySatisfy = many . satisfy
282 manySatisfy1 = many1 . satisfy
283
284 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
285 manySatisfy_ = many_ . satisfy
286 manySatisfy1_ = many1_ . satisfy
287
288 ------------------------------------------------------------------------
289 -- Parser of hsc syntax.
290
291 data Token
292 = Text SourcePos String
293 | Special SourcePos String String
294
295 parser :: Parser [Token]
296 parser = do
297 pos <- getPos
298 t <- catchOutput_ text
299 s <- lookAhead
300 rest <- case s of
301 [] -> return []
302 _:_ -> liftM2 (:) (special `fakeOutput` []) parser
303 return (if null t then rest else Text pos t : rest)
304
305 text :: Parser ()
306 text = do
307 s <- lookAhead
308 case s of
309 [] -> return ()
310 c:_ | isAlpha c || c == '_' -> do
311 anyChar_
312 manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
313 text
314 c:_ | isHsSymbol c -> do
315 symb <- catchOutput_ (manySatisfy_ isHsSymbol)
316 case symb of
317 "#" -> return ()
318 '-':'-':symb' | all (== '-') symb' -> do
319 return () `fakeOutput` symb
320 manySatisfy_ (/= '\n')
321 text
322 _ -> do
323 return () `fakeOutput` unescapeHashes symb
324 text
325 '\"':_ -> do anyChar_; hsString '\"'; text
326 '\'':_ -> do anyChar_; hsString '\''; text
327 '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
328 _:_ -> do anyChar_; text
329
330 hsString :: Char -> Parser ()
331 hsString quote = do
332 s <- lookAhead
333 case s of
334 [] -> return ()
335 c:_ | c == quote -> anyChar_
336 '\\':c:_
337 | isSpace c -> do
338 anyChar_
339 manySatisfy_ isSpace
340 char_ '\\' `mplus` return ()
341 hsString quote
342 | otherwise -> do any2Chars_; hsString quote
343 _:_ -> do anyChar_; hsString quote
344
345 hsComment :: Parser ()
346 hsComment = do
347 s <- lookAhead
348 case s of
349 [] -> return ()
350 '-':'}':_ -> any2Chars_
351 '{':'-':_ -> do any2Chars_; hsComment; hsComment
352 _:_ -> do anyChar_; hsComment
353
354 linePragma :: Parser ()
355 linePragma = do
356 char_ '#'
357 manySatisfy_ isSpace
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
365 char_ '\"'
366 name <- manySatisfy (/= '\"')
367 char_ '\"'
368 manySatisfy_ isSpace
369 char_ '#'
370 char_ '-'
371 char_ '}'
372 setPos (SourcePos name (line - 1))
373
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
382 isHsSymbol _ = False
383
384 unescapeHashes :: String -> String
385 unescapeHashes [] = []
386 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
387 unescapeHashes (c:s) = c : unescapeHashes s
388
389 lookAheadC :: Parser String
390 lookAheadC = liftM joinLines lookAhead
391 where
392 joinLines [] = []
393 joinLines ('\\':'\n':s) = joinLines s
394 joinLines (c:s) = c : joinLines s
395
396 satisfyC :: (Char -> Bool) -> Parser Char
397 satisfyC p = do
398 s <- lookAhead
399 case s of
400 '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
401 _ -> satisfy p
402
403 charC_ :: Char -> Parser ()
404 charC_ c = do
405 satisfyC (== c) `message` (show c++" expected")
406 return ()
407
408 anyCharC_ :: Parser ()
409 anyCharC_ = do
410 satisfyC (const True) `message` "Unexpected end of file"
411 return ()
412
413 any2CharsC_ :: Parser ()
414 any2CharsC_ = anyCharC_ >> anyCharC_
415
416 manySatisfyC :: (Char -> Bool) -> Parser String
417 manySatisfyC = many . satisfyC
418
419 manySatisfyC_ :: (Char -> Bool) -> Parser ()
420 manySatisfyC_ = many_ . satisfyC
421
422 special :: Parser Token
423 special = do
424 manySatisfyC_ (\c -> isSpace c && c /= '\n')
425 s <- lookAheadC
426 case s of
427 '{':_ -> do
428 anyCharC_
429 manySatisfyC_ isSpace
430 sp <- keyArg (== '\n')
431 charC_ '}'
432 return sp
433 _ -> keyArg (const False)
434
435 keyArg :: (Char -> Bool) -> Parser Token
436 keyArg eol = do
437 pos <- getPos
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)
442
443 keyword :: Parser String
444 keyword = do
445 c <- satisfyC (\c' -> isAlpha c' || c' == '_')
446 cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
447 return (c:cs)
448
449 argument :: (Char -> Bool) -> Parser ()
450 argument eol = do
451 s <- lookAheadC
452 case s of
453 [] -> return ()
454 c:_ | eol c -> do anyCharC_; argument eol
455 '\n':_ -> return ()
456 '\"':_ -> do anyCharC_; cString '\"'; argument eol
457 '\'':_ -> do anyCharC_; cString '\''; argument eol
458 '(':_ -> do anyCharC_; nested ')'; argument eol
459 ')':_ -> return ()
460 '/':'*':_ -> do any2CharsC_; cComment; argument eol
461 '/':'/':_ -> do
462 any2CharsC_; manySatisfyC_ (/= '\n'); argument eol
463 '[':_ -> do anyCharC_; nested ']'; argument eol
464 ']':_ -> return ()
465 '{':_ -> do anyCharC_; nested '}'; argument eol
466 '}':_ -> return ()
467 _:_ -> do anyCharC_; argument eol
468
469 nested :: Char -> Parser ()
470 nested c = do argument (== '\n'); charC_ c
471
472 cComment :: Parser ()
473 cComment = do
474 s <- lookAheadC
475 case s of
476 [] -> return ()
477 '*':'/':_ -> do any2CharsC_
478 _:_ -> do anyCharC_; cComment
479
480 cString :: Char -> Parser ()
481 cString quote = do
482 s <- lookAheadC
483 case s of
484 [] -> return ()
485 c:_ | c == quote -> anyCharC_
486 '\\':_:_ -> do any2CharsC_; cString quote
487 _:_ -> do anyCharC_; cString quote
488
489 ------------------------------------------------------------------------
490 -- Write the output files.
491
492 splitName :: String -> (String, String)
493 splitName name =
494 case break (== '/') name of
495 (file, []) -> ([], file)
496 (dir, sep:rest) -> (dir++sep:restDir, restFile)
497 where
498 (restDir, restFile) = splitName rest
499
500 splitExt :: String -> (String, String)
501 splitExt name =
502 case break (== '.') name of
503 (base, []) -> (base, [])
504 (base, sepRest@(sep:rest))
505 | null restExt -> (base, sepRest)
506 | otherwise -> (base++sep:restBase, restExt)
507 where
508 (restBase, restExt) = splitExt rest
509
510 output :: [Flag] -> String -> [Token] -> IO ()
511 output flags name toks = do
512
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)
516 else
517 if ext == ".hs"
518 then return (dir++base++"_out.hs", dir, base)
519 else return (dir++base++".hs", dir, base)
520 where
521 (dir, file) = splitName name
522 (base, ext) = splitExt file
523 [f] -> let
524 (dir, file) = splitName f
525 (base, _) = splitExt file
526 in return (f, dir, base)
527 _ -> onlyOne "output file"
528
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 * * *
535 ++ ".exe"
536 #endif
537 outHFile = outBase++"_hsc.h"
538 outHName = outDir++outHFile
539 outCName = outDir++outBase++"_hsc.c"
540
541 beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
542
543 let execProgName
544 | null outDir = dosifyPath ("./" ++ progName)
545 | otherwise = progName
546
547 let specials = [(pos, key, arg) | Special pos key arg <- toks]
548
549 let needsC = any (\(_, key, _) -> key == "def") specials
550 needsH = needsC
551
552 let includeGuard = map fixChar outHName
553 where
554 fixChar c | isAlphaNum c = toUpper c
555 | otherwise = '_'
556
557 -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
558 -- Returns a native-format path
559 locateGhc def = do
560 mb <- getExecDir "bin/hsc2hs.exe"
561 case mb of
562 Nothing -> return def
563 Just x -> do
564 let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
565 flg <- doesFileExist ghc_path
566 if flg
567 then return ghc_path
568 else return def
569
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.
573 --
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
577 --
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"
582 [c] -> return c
583 _ -> onlyOne "compiler"
584
585 linker <- case [l | Linker l <- flags] of
586 [] -> locateGhc compiler
587 [l] -> return l
588 _ -> onlyOne "linker"
589
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++
597 " return 0;\n}\n"
598
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) $
602 exitWith ExitSuccess
603
604 rawSystemL ("compiling " ++ cProgName) beVerbose compiler
605 ( ["-c"]
606 ++ [f | CompFlag f <- flags]
607 ++ [cProgName]
608 ++ ["-o", oProgName]
609 )
610 finallyRemove cProgName $ do
611
612 rawSystemL ("linking " ++ oProgName) beVerbose linker
613 ( [f | LinkFlag f <- flags]
614 ++ [oProgName]
615 ++ ["-o", progName]
616 )
617 finallyRemove oProgName $ do
618
619 rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
620 finallyRemove progName $ do
621
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" ++
627 "#endif\n" ++
628 "#include <HsFFI.h>\n" ++
629 "#if __NHC__\n" ++
630 "#undef HsChar\n" ++
631 "#define HsChar int\n" ++
632 "#endif\n" ++
633 concatMap outFlagH flags++
634 concatMap outTokenH specials++
635 "#endif\n"
636
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.
642
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
649 #else
650 exitStatus <- rawSystem prog args
651 #endif
652 case exitStatus of
653 ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
654 _ -> return ()
655
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
662 #else
663 hOut <- openFile outFile WriteMode
664 process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing
665 exitStatus <- waitForProcess process
666 hClose hOut
667 #endif
668 case exitStatus of
669 ExitFailure _ -> die $ action ++ " failed\ncommand was: " ++ cmdLine ++ "\n"
670 _ -> return ()
671
672
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 =
678 bracket_ (return fp)
679 (const $ noisyRemove fp)
680 act
681 where
682 noisyRemove fpath =
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")
687
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 _ = ""
694
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"
700 "def" -> case arg of
701 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
702 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
703 _ -> ""
704 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
705 "let" -> case break (== '=') arg of
706 (_, "") -> ""
707 (header, _:body) -> case break isSpace header of
708 (name, args) ->
709 outCLine pos++
710 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
711 "printf ("++joinLines body++");\n"
712 _ -> ""
713 where
714 joinLines = concat . intersperse " \\\n" . lines
715
716 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
717 outHeaderHs flags inH toks =
718 "#if " ++
719 "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
720 " printf (\"{-# OPTIONS -optc-D" ++
721 "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
722 "__GLASGOW_HASKELL__);\n" ++
723 "#endif\n"++
724 case inH of
725 Nothing -> concatMap outFlag flags++concatMap outSpecial toks
726 Just f -> outInclude ("\""++f++"\"")
727 where
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)
731 outFlag _ = ""
732 outSpecial (pos, key, arg) = case key of
733 "include" -> outInclude arg
734 "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
735 | otherwise -> ""
736 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
737 _ -> ""
738 goodForOptD arg = case arg of
739 "" -> True
740 c:_ | isSpace c -> True
741 '(':_ -> False
742 _:s -> goodForOptD s
743 toOptD arg = case break isSpace arg of
744 (name, "") -> name
745 (name, _:value) -> name++'=':dropWhile isSpace value
746 outOption s =
747 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
748 " printf (\"{-# OPTIONS %s #-}\\n\", \""++
749 showCString s++"\");\n"++
750 "#else\n"++
751 " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
752 showCString s++"\");\n"++
753 "#endif\n"
754 outInclude s =
755 "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
756 " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++
757 showCString s++"\");\n"++
758 "#else\n"++
759 " printf (\"{-# INCLUDE %s #-}\\n\", \""++
760 showCString s++"\");\n"++
761 "#endif\n"
762
763 outTokenHs :: Token -> String
764 outTokenHs (Text pos txt) =
765 case break (== '\n') txt of
766 (allTxt, []) -> outText allTxt
767 (first, _:rest) ->
768 outText (first++"\n")++
769 outHsLine pos++
770 outText rest
771 where
772 outText s = " fputs (\""++showCString s++"\", stdout);\n"
773 outTokenHs (Special pos key arg) =
774 case key of
775 "include" -> ""
776 "define" -> ""
777 "undef" -> ""
778 "def" -> ""
779 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
780 "let" -> ""
781 "enum" -> outCLine pos++outEnum arg
782 _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n"
783
784 outEnum :: String -> String
785 outEnum arg =
786 case break (== ',') arg of
787 (_, []) -> ""
788 (t, _:afterT) -> case break (== ',') afterT of
789 (f, afterF) -> let
790 enums [] = ""
791 enums (_:s) = case break (== ',') s of
792 (enum, rest) -> let
793 this = case break (== '=') $ dropWhile isSpace enum of
794 (name, []) ->
795 " hsc_enum ("++t++", "++f++", " ++
796 "hsc_haskellize (\""++name++"\"), "++
797 name++");\n"
798 (hsName, _:cName) ->
799 " hsc_enum ("++t++", "++f++", " ++
800 "printf (\"%s\", \""++hsName++"\"), "++
801 cName++");\n"
802 in this++enums rest
803 in enums afterF
804
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"
809 outFlagH _ = ""
810
811 outTokenH :: (SourcePos, String, String) -> String
812 outTokenH (pos, key, arg) =
813 case key of
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" ++
822 "extern\n" ++
823 "#endif\n"++
824 arg++"\n"
825 _ -> "extern "++header++";\n"
826 where header = takeWhile (\c -> c /= '{' && c /= '=') arg
827 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
828 _ -> ""
829
830 outTokenC :: (SourcePos, String, String) -> String
831 outTokenC (pos, key, arg) =
832 case key of
833 "def" -> case arg of
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
838 (header, body) ->
839 outCLine pos++
840 "#ifndef __GNUC__\n" ++
841 "extern inline\n" ++
842 "#endif\n"++
843 header++
844 "\n#ifndef __GNUC__\n" ++
845 ";\n" ++
846 "#else\n"++
847 body++
848 "\n#endif\n"
849 _ -> outCLine pos++arg++"\n"
850 _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
851 _ -> ""
852
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
863
864 outCLine :: SourcePos -> String
865 outCLine (SourcePos name line) =
866 "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
867
868 outHsLine :: SourcePos -> String
869 outHsLine (SourcePos name line) =
870 " hsc_line ("++show (line + 1)++", \""++
871 showCString name++"\");\n"
872
873 showCString :: String -> String
874 showCString = concatMap showCChar
875 where
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"
888 showCChar c = ['\\',
889 intToDigit (ord c `quot` 64),
890 intToDigit (ord c `quot` 8 `mod` 8),
891 intToDigit (ord c `mod` 8)]
892
893 -----------------------------------------
894 -- Modified version from ghc/compiler/SysTools
895 -- Convert paths foo/baz to foo\baz on Windows
896
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)
900 #else
901 subst _ _ = id
902 #endif
903
904 dosifyPath :: String -> String
905 dosifyPath = subst '/' '\\'
906
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)
912 getExecDir cmd =
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
917
918 getExecPath :: IO (Maybe String)
919 #if defined(mingw32_HOST_OS)
920 getExecPath =
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.
926
927 foreign import stdcall unsafe "GetModuleFileNameA"
928 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
929 #else
930 getExecPath = return Nothing
931 #endif