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