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