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)
  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     removeFile cProgName
 601
 602     rawSystemL ("linking " ++ oProgName) beVerbose linker
 603         (  [f | LinkFlag f <- flags]
 604         ++ [oProgName]
 605         ++ ["-o", progName]
 606         )
 607     removeFile oProgName
 608
 609     rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName
 610     removeFile progName
 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 onlyOne :: String -> IO a
 663 onlyOne what = die ("Only one "++what++" may be specified\n")
 664
 665 outFlagHeaderCProg :: Flag -> String
 666 outFlagHeaderCProg (Template t)          = "#include \""++t++"\"\n"
 667 outFlagHeaderCProg (Include  f)          = "#include "++f++"\n"
 668 outFlagHeaderCProg (Define   n Nothing)  = "#define "++n++" 1\n"
 669 outFlagHeaderCProg (Define   n (Just v)) = "#define "++n++" "++v++"\n"
 670 outFlagHeaderCProg _                     = ""
 671
 672 outHeaderCProg :: (SourcePos, String, String) -> String
 673 outHeaderCProg (pos, key, arg) = case key of
 674     "include"           -> outCLine pos++"#include "++arg++"\n"
 675     "define"            -> outCLine pos++"#define "++arg++"\n"
 676     "undef"             -> outCLine pos++"#undef "++arg++"\n"
 677     "def"               -> case arg of
 678         's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
 679         't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
 680         _ -> ""
 681     _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 682     "let"               -> case break (== '=') arg of
 683         (_,      "")     -> ""
 684         (header, _:body) -> case break isSpace header of
 685             (name, args) ->
 686                 outCLine pos++
 687                 "#define hsc_"++name++"("++dropWhile isSpace args++") " ++
 688                 "printf ("++joinLines body++");\n"
 689     _ -> ""
 690    where
 691     joinLines = concat . intersperse " \\\n" . lines
 692
 693 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
 694 outHeaderHs flags inH toks =
 695     "#if " ++
 696     "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++
 697     "    printf (\"{-# OPTIONS -optc-D" ++
 698     "__GLASGOW_HASKELL__=%d #-}\\n\", " ++
 699     "__GLASGOW_HASKELL__);\n" ++
 700     "#endif\n"++
 701     case inH of
 702         Nothing -> concatMap outFlag flags++concatMap outSpecial toks
 703         Just f  -> outInclude ("\""++f++"\"")
 704     where
 705     outFlag (Include f)          = outInclude f
 706     outFlag (Define  n Nothing)  = outOption ("-optc-D"++n)
 707     outFlag (Define  n (Just v)) = outOption ("-optc-D"++n++"="++v)
 708     outFlag _                    = ""
 709     outSpecial (pos, key, arg) = case key of
 710         "include"                  -> outInclude arg
 711         "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
 712                  | otherwise       -> ""
 713         _ | conditional key        -> outCLine pos++"#"++key++" "++arg++"\n"
 714         _                          -> ""
 715     goodForOptD arg = case arg of
 716         ""              -> True
 717         c:_ | isSpace c -> True
 718         '(':_           -> False
 719         _:s             -> goodForOptD s
 720     toOptD arg = case break isSpace arg of
 721         (name, "")      -> name
 722         (name, _:value) -> name++'=':dropWhile isSpace value
 723     outOption s =
 724         "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
 725         "    printf (\"{-# OPTIONS %s #-}\\n\", \""++
 726                   showCString s++"\");\n"++
 727         "#else\n"++
 728         "    printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++
 729                   showCString s++"\");\n"++
 730         "#endif\n"
 731     outInclude s =
 732         "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++
 733         "    printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++
 734                   showCString s++"\");\n"++
 735         "#else\n"++
 736         "    printf (\"{-# INCLUDE %s #-}\\n\", \""++
 737                   showCString s++"\");\n"++
 738         "#endif\n"
 739
 740 outTokenHs :: Token -> String
 741 outTokenHs (Text pos txt) =
 742     case break (== '\n') txt of
 743         (allTxt, [])       -> outText allTxt
 744         (first, _:rest) ->
 745             outText (first++"\n")++
 746             outHsLine pos++
 747             outText rest
 748     where
 749     outText s = "    fputs (\""++showCString s++"\", stdout);\n"
 750 outTokenHs (Special pos key arg) =
 751     case key of
 752         "include"           -> ""
 753         "define"            -> ""
 754         "undef"             -> ""
 755         "def"               -> ""
 756         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 757         "let"               -> ""
 758         "enum"              -> outCLine pos++outEnum arg
 759         _                   -> outCLine pos++"    hsc_"++key++" ("++arg++");\n"
 760
 761 outEnum :: String -> String
 762 outEnum arg =
 763     case break (== ',') arg of
 764         (_, [])        -> ""
 765         (t, _:afterT) -> case break (== ',') afterT of
 766             (f, afterF) -> let
 767                 enums []    = ""
 768                 enums (_:s) = case break (== ',') s of
 769                     (enum, rest) -> let
 770                         this = case break (== '=') $ dropWhile isSpace enum of
 771                             (name, []) ->
 772                                 "    hsc_enum ("++t++", "++f++", " ++
 773                                 "hsc_haskellize (\""++name++"\"), "++
 774                                 name++");\n"
 775                             (hsName, _:cName) ->
 776                                 "    hsc_enum ("++t++", "++f++", " ++
 777                                 "printf (\"%s\", \""++hsName++"\"), "++
 778                                 cName++");\n"
 779                         in this++enums rest
 780                 in enums afterF
 781
 782 outFlagH :: Flag -> String
 783 outFlagH (Include  f)          = "#include "++f++"\n"
 784 outFlagH (Define   n Nothing)  = "#define "++n++" 1\n"
 785 outFlagH (Define   n (Just v)) = "#define "++n++" "++v++"\n"
 786 outFlagH _                     = ""
 787
 788 outTokenH :: (SourcePos, String, String) -> String
 789 outTokenH (pos, key, arg) =
 790     case key of
 791         "include" -> outCLine pos++"#include "++arg++"\n"
 792         "define"  -> outCLine pos++"#define " ++arg++"\n"
 793         "undef"   -> outCLine pos++"#undef "  ++arg++"\n"
 794         "def"     -> outCLine pos++case arg of
 795             's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 796             't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 797             'i':'n':'l':'i':'n':'e':' ':_ ->
 798                 "#ifdef __GNUC__\n" ++
 799                 "extern\n" ++
 800                 "#endif\n"++
 801                 arg++"\n"
 802             _ -> "extern "++header++";\n"
 803           where header = takeWhile (\c -> c /= '{' && c /= '=') arg
 804         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 805         _ -> ""
 806
 807 outTokenC :: (SourcePos, String, String) -> String
 808 outTokenC (pos, key, arg) =
 809     case key of
 810         "def" -> case arg of
 811             's':'t':'r':'u':'c':'t':' ':_ -> ""
 812             't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
 813             'i':'n':'l':'i':'n':'e':' ':arg' ->
 814                 case span (\c -> c /= '{' && c /= '=') arg' of
 815                 (header, body) ->
 816                     outCLine pos++
 817                     "#ifndef __GNUC__\n" ++
 818                     "extern inline\n" ++
 819                     "#endif\n"++
 820                     header++
 821                     "\n#ifndef __GNUC__\n" ++
 822                     ";\n" ++
 823                     "#else\n"++
 824                     body++
 825                     "\n#endif\n"
 826             _ -> outCLine pos++arg++"\n"
 827         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 828         _ -> ""
 829
 830 conditional :: String -> Bool
 831 conditional "if"      = True
 832 conditional "ifdef"   = True
 833 conditional "ifndef"  = True
 834 conditional "elif"    = True
 835 conditional "else"    = True
 836 conditional "endif"   = True
 837 conditional "error"   = True
 838 conditional "warning" = True
 839 conditional _         = False
 840
 841 outCLine :: SourcePos -> String
 842 outCLine (SourcePos name line) =
 843     "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
 844
 845 outHsLine :: SourcePos -> String
 846 outHsLine (SourcePos name line) =
 847     "    hsc_line ("++show (line + 1)++", \""++
 848     showCString name++"\");\n"
 849
 850 showCString :: String -> String
 851 showCString = concatMap showCChar
 852     where
 853     showCChar '\"' = "\\\""
 854     showCChar '\'' = "\\\'"
 855     showCChar '?'  = "\\?"
 856     showCChar '\\' = "\\\\"
 857     showCChar c | c >= ' ' && c <= '~' = [c]
 858     showCChar '\a' = "\\a"
 859     showCChar '\b' = "\\b"
 860     showCChar '\f' = "\\f"
 861     showCChar '\n' = "\\n\"\n           \""
 862     showCChar '\r' = "\\r"
 863     showCChar '\t' = "\\t"
 864     showCChar '\v' = "\\v"
 865     showCChar c    = ['\\',
 866                       intToDigit (ord c `quot` 64),
 867                       intToDigit (ord c `quot` 8 `mod` 8),
 868                       intToDigit (ord c          `mod` 8)]
 869
 870 -----------------------------------------
 871 -- Modified version from ghc/compiler/SysTools
 872 -- Convert paths foo/baz to foo\baz on Windows
 873
 874 subst :: Char -> Char -> String -> String
 875 #if defined(mingw32_HOST_OS) || defined(__CYGWIN32__)
 876 subst a b = map (\x -> if x == a then b else x)
 877 #else
 878 subst _ _ = id
 879 #endif
 880
 881 dosifyPath :: String -> String
 882 dosifyPath = subst '/' '\\'
 883
 884 -- (getExecDir cmd) returns the directory in which the current
 885 --                  executable, which should be called 'cmd', is running
 886 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
 887 -- you'll get "/a/b/c" back as the result
 888 getExecDir :: String -> IO (Maybe String)
 889 getExecDir cmd =
 890     getExecPath >>= maybe (return Nothing) removeCmdSuffix
 891     where unDosifyPath = subst '\\' '/'
 892           initN n = reverse . drop n . reverse
 893           removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
 894
 895 getExecPath :: IO (Maybe String)
 896 #if defined(mingw32_HOST_OS)
 897 getExecPath =
 898      allocaArray len $ \buf -> do
 899          ret <- getModuleFileName nullPtr buf len
 900          if ret == 0 then return Nothing
 901                      else liftM Just $ peekCString buf
 902     where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
 903
 904 foreign import stdcall unsafe "GetModuleFileNameA"
 905     getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 906 #else
 907 getExecPath = return Nothing
 908 #endif