ghc/utils/hsc2hs/Main.hs

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