ghc/utils/hsc2hs/Main.hs

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