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