ghc/utils/hsc2hs/Main.hs

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