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