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