ghc/utils/hsc2hs/Main.hs

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