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