ghc/utils/hsc2hs/Main.hs

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