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