ghc/utils/hsc2hs/Main.hs

   1 ------------------------------------------------------------------------
   2 -- $Id: Main.hs,v 1.26 2001/03/16 09:07:41 qrczak Exp $
   3 --
   4 -- Program for converting .hsc files to .hs files, by converting the
   5 -- file into a C program which is run to generate the Haskell source.
   6 -- Certain items known only to the C compiler can then be used in
   7 -- the Haskell module; for example #defined constants, byte offsets
   8 -- within structures, etc.
   9 --
  10 -- See the documentation in the Users' Guide for more details.
  11
  12 import GetOpt
  13 import System        (getProgName, getArgs, ExitCode(..), exitWith, exitFailure)
  14 import KludgedSystem (system, defaultCompiler)
  15 import Directory     (removeFile)
  16 import Monad         (MonadPlus(..), liftM, liftM2, when, unless)
  17 import Char          (isAlpha, isAlphaNum, isSpace, isDigit, toUpper, intToDigit, ord)
  18 import List          (intersperse)
  19
  20 version :: String
  21 version = "hsc2hs-0.65"
  22
  23 data Flag
  24     = Help
  25     | Version
  26     | Template  String
  27     | Compiler  String
  28     | Linker    String
  29     | CompFlag  String
  30     | LinkFlag  String
  31     | NoCompile
  32     | Include   String
  33
  34 include :: String -> Flag
  35 include s@('\"':_) = Include s
  36 include s@('<' :_) = Include s
  37 include s          = Include ("\""++s++"\"")
  38
  39 options :: [OptDescr Flag]
  40 options = [
  41     Option "t" ["template"]   (ReqArg Template   "FILE") "template file",
  42     Option "c" ["cc"]         (ReqArg Compiler   "PROG") "C compiler to use",
  43     Option "l" ["ld"]         (ReqArg Linker     "PROG") "linker to use",
  44     Option "C" ["cflag"]      (ReqArg CompFlag   "FLAG") "flag to pass to the C compiler",
  45     Option "I" []             (ReqArg (CompFlag . ("-I"++))
  46                                                  "DIR")  "passed to the C compiler",
  47     Option "L" ["lflag"]      (ReqArg LinkFlag   "FLAG") "flag to pass to the linker",
  48     Option ""  ["no-compile"] (NoArg  NoCompile)         "stop after writing *.hs_make.c",
  49     Option "i" ["include"]    (ReqArg include    "FILE") "as if placed in the source",
  50     Option ""  ["help"]       (NoArg  Help)              "display this help and exit",
  51     Option ""  ["version"]    (NoArg  Version)           "output version information and exit"]
  52
  53 main :: IO ()
  54 main = do
  55     prog <- getProgName
  56     let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]"
  57     args <- getArgs
  58     case getOpt Permute options args of
  59         (flags, _, _)
  60             | any isHelp    flags -> putStrLn (usageInfo header options)
  61             | any isVersion flags -> putStrLn version
  62             where
  63             isHelp    Help    = True; isHelp    _ = False
  64             isVersion Version = True; isVersion _ = False
  65         (_,     [],    [])   -> putStrLn (prog++": No input files")
  66         (flags, files, [])   -> mapM_ (processFile flags) files
  67         (_,     _,     errs) -> do
  68             mapM_ putStrLn errs
  69             putStrLn (usageInfo header options)
  70             exitFailure
  71
  72 processFile :: [Flag] -> String -> IO ()
  73 processFile flags name = do
  74     s <- readFile name
  75     case parser of
  76         Parser p -> case p (SourcePos name 1) s of
  77             Success _ _ _ toks -> output flags name toks
  78             Failure (SourcePos name' line) msg -> do
  79                 putStrLn (name'++":"++show line++": "++msg)
  80                 exitFailure
  81
  82 ------------------------------------------------------------------------
  83 -- A deterministic parser which remembers the text which has been parsed.
  84
  85 newtype Parser a = Parser (SourcePos -> String -> ParseResult a)
  86
  87 data ParseResult a = Success !SourcePos String String a
  88                    | Failure !SourcePos String
  89
  90 data SourcePos = SourcePos String !Int
  91
  92 updatePos :: SourcePos -> Char -> SourcePos
  93 updatePos pos@(SourcePos name line) ch = case ch of
  94     '\n' -> SourcePos name (line + 1)
  95     _    -> pos
  96
  97 instance Monad Parser where
  98     return a = Parser $ \pos s -> Success pos [] s a
  99     Parser m >>= k =
 100         Parser $ \pos s -> case m pos s of
 101             Success pos' out1 s' a -> case k a of
 102                 Parser k' -> case k' pos' s' of
 103                     Success pos'' out2 imp'' b ->
 104                         Success pos'' (out1++out2) imp'' b
 105                     Failure pos'' msg -> Failure pos'' msg
 106             Failure pos' msg -> Failure pos' msg
 107     fail msg = Parser $ \pos _ -> Failure pos msg
 108
 109 instance MonadPlus Parser where
 110     mzero                     = fail "mzero"
 111     Parser m `mplus` Parser n =
 112         Parser $ \pos s -> case m pos s of
 113             success@(Success _ _ _ _) -> success
 114             Failure _ _               -> n pos s
 115
 116 getPos :: Parser SourcePos
 117 getPos = Parser $ \pos s -> Success pos [] s pos
 118
 119 setPos :: SourcePos -> Parser ()
 120 setPos pos = Parser $ \_ s -> Success pos [] s ()
 121
 122 message :: Parser a -> String -> Parser a
 123 Parser m `message` msg =
 124     Parser $ \pos s -> case m pos s of
 125         success@(Success _ _ _ _) -> success
 126         Failure pos' _            -> Failure pos' msg
 127
 128 catchOutput_ :: Parser a -> Parser String
 129 catchOutput_ (Parser m) =
 130     Parser $ \pos s -> case m pos s of
 131         Success pos' out s' _ -> Success pos' [] s' out
 132         Failure pos' msg      -> Failure pos' msg
 133
 134 fakeOutput :: Parser a -> String -> Parser a
 135 Parser m `fakeOutput` out =
 136     Parser $ \pos s -> case m pos s of
 137         Success pos' _ s' a -> Success pos' out s' a
 138         Failure pos' msg    -> Failure pos' msg
 139
 140 lookAhead :: Parser String
 141 lookAhead = Parser $ \pos s -> Success pos [] s s
 142
 143 satisfy :: (Char -> Bool) -> Parser Char
 144 satisfy p =
 145     Parser $ \pos s -> case s of
 146         c:cs | p c -> Success (updatePos pos c) [c] cs c
 147         _          -> Failure pos "Bad character"
 148
 149 char_ :: Char -> Parser ()
 150 char_ c = do
 151     satisfy (== c) `message` (show c++" expected")
 152     return ()
 153
 154 anyChar_ :: Parser ()
 155 anyChar_ = do
 156     satisfy (const True) `message` "Unexpected end of file"
 157     return ()
 158
 159 any2Chars_ :: Parser ()
 160 any2Chars_ = anyChar_ >> anyChar_
 161
 162 many :: Parser a -> Parser [a]
 163 many p = many1 p `mplus` return []
 164
 165 many1 :: Parser a -> Parser [a]
 166 many1 p = liftM2 (:) p (many p)
 167
 168 many_ :: Parser a -> Parser ()
 169 many_ p = many1_ p `mplus` return ()
 170
 171 many1_ :: Parser a -> Parser ()
 172 many1_ p = p >> many_ p
 173
 174 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
 175 manySatisfy  = many  . satisfy
 176 manySatisfy1 = many1 . satisfy
 177
 178 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
 179 manySatisfy_  = many_  . satisfy
 180 manySatisfy1_ = many1_ . satisfy
 181
 182 ------------------------------------------------------------------------
 183 -- Parser of hsc syntax.
 184
 185 data Token
 186     = Text    SourcePos String
 187     | Special SourcePos String String
 188
 189 parser :: Parser [Token]
 190 parser = do
 191     pos <- getPos
 192     t <- catchOutput_ text
 193     s <- lookAhead
 194     rest <- case s of
 195         []  -> return []
 196         _:_ -> liftM2 (:) (special `fakeOutput` []) parser
 197     return (if null t then rest else Text pos t : rest)
 198
 199 text :: Parser ()
 200 text = do
 201     s <- lookAhead
 202     case s of
 203         []        -> return ()
 204         c:_ | isAlpha c || c == '_' -> do
 205             anyChar_
 206             manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
 207             text
 208         c:_ | isHsSymbol c -> do
 209             symb <- catchOutput_ (manySatisfy_ isHsSymbol)
 210             case symb of
 211                 "#" -> return ()
 212                 '-':'-':symb' | all (== '-') symb' -> do
 213                     return () `fakeOutput` symb
 214                     manySatisfy_ (/= '\n')
 215                     text
 216                 _ -> do
 217                     return () `fakeOutput` unescapeHashes symb
 218                     text
 219         '\"':_    -> do anyChar_; hsString '\"'; text
 220         '\'':_    -> do anyChar_; hsString '\''; text
 221         '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
 222         _:_       -> do anyChar_; text
 223
 224 hsString :: Char -> Parser ()
 225 hsString quote = do
 226     s <- lookAhead
 227     case s of
 228         []               -> return ()
 229         c:_ | c == quote -> anyChar_
 230         '\\':c:_
 231             | isSpace c  -> do
 232                 anyChar_
 233                 manySatisfy_ isSpace
 234                 char_ '\\' `mplus` return ()
 235                 hsString quote
 236             | otherwise  -> do any2Chars_; hsString quote
 237         _:_              -> do anyChar_; hsString quote
 238
 239 hsComment :: Parser ()
 240 hsComment = do
 241     s <- lookAhead
 242     case s of
 243         []        -> return ()
 244         '-':'}':_ -> any2Chars_
 245         '{':'-':_ -> do any2Chars_; hsComment; hsComment
 246         _:_       -> do anyChar_; hsComment
 247
 248 linePragma :: Parser ()
 249 linePragma = do
 250     char_ '#'
 251     manySatisfy_ isSpace
 252     satisfy (\c -> c == 'L' || c == 'l')
 253     satisfy (\c -> c == 'I' || c == 'i')
 254     satisfy (\c -> c == 'N' || c == 'n')
 255     satisfy (\c -> c == 'E' || c == 'e')
 256     manySatisfy1_ isSpace
 257     line <- liftM read $ manySatisfy1 isDigit
 258     manySatisfy1_ isSpace
 259     char_ '\"'
 260     name <- manySatisfy (/= '\"')
 261     char_ '\"'
 262     manySatisfy_ isSpace
 263     char_ '#'
 264     char_ '-'
 265     char_ '}'
 266     setPos (SourcePos name (line - 1))
 267
 268 isHsSymbol :: Char -> Bool
 269 isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$'  = True
 270 isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*'  = True
 271 isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/'  = True
 272 isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>'  = True
 273 isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True
 274 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-'  = True
 275 isHsSymbol '~' = True
 276 isHsSymbol _   = False
 277
 278 unescapeHashes :: String -> String
 279 unescapeHashes []          = []
 280 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
 281 unescapeHashes (c:s)       = c   : unescapeHashes s
 282
 283 lookAheadC :: Parser String
 284 lookAheadC = liftM joinLines lookAhead
 285     where
 286     joinLines []            = []
 287     joinLines ('\\':'\n':s) = joinLines s
 288     joinLines (c:s)         = c : joinLines s
 289
 290 satisfyC :: (Char -> Bool) -> Parser Char
 291 satisfyC p = do
 292     s <- lookAhead
 293     case s of
 294         '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
 295         _           -> satisfy p
 296
 297 charC_ :: Char -> Parser ()
 298 charC_ c = do
 299     satisfyC (== c) `message` (show c++" expected")
 300     return ()
 301
 302 anyCharC_ :: Parser ()
 303 anyCharC_ = do
 304     satisfyC (const True) `message` "Unexpected end of file"
 305     return ()
 306
 307 any2CharsC_ :: Parser ()
 308 any2CharsC_ = anyCharC_ >> anyCharC_
 309
 310 manySatisfyC :: (Char -> Bool) -> Parser String
 311 manySatisfyC = many . satisfyC
 312
 313 manySatisfyC_ :: (Char -> Bool) -> Parser ()
 314 manySatisfyC_ = many_ . satisfyC
 315
 316 special :: Parser Token
 317 special = do
 318     manySatisfyC_ (\c -> isSpace c && c /= '\n')
 319     s <- lookAheadC
 320     case s of
 321         '{':_ -> do
 322             anyCharC_
 323             manySatisfyC_ isSpace
 324             sp <- keyArg (== '\n')
 325             charC_ '}'
 326             return sp
 327         _ -> keyArg (const False)
 328
 329 keyArg :: (Char -> Bool) -> Parser Token
 330 keyArg eol = do
 331     pos <- getPos
 332     key <- keyword `message` "hsc keyword or '{' expected"
 333     manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
 334     arg <- catchOutput_ (argument eol)
 335     return (Special pos key arg)
 336
 337 keyword :: Parser String
 338 keyword = do
 339     c  <- satisfyC (\c' -> isAlpha c' || c' == '_')
 340     cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
 341     return (c:cs)
 342
 343 argument :: (Char -> Bool) -> Parser ()
 344 argument eol = do
 345     s <- lookAheadC
 346     case s of
 347         []          -> return ()
 348         c:_ | eol c -> do anyCharC_;               argument eol
 349         '\n':_      -> return ()
 350         '\"':_      -> do anyCharC_; cString '\"'; argument eol
 351         '\'':_      -> do anyCharC_; cString '\''; argument eol
 352         '(':_       -> do anyCharC_; nested ')';   argument eol
 353         ')':_       -> return ()
 354         '/':'*':_   -> do any2CharsC_; cComment;   argument eol
 355         '/':'/':_   -> do
 356             any2CharsC_; manySatisfyC_ (/= '\n');  argument eol
 357         '[':_       -> do anyCharC_; nested ']';   argument eol
 358         ']':_       -> return ()
 359         '{':_       -> do anyCharC_; nested '}';   argument eol
 360         '}':_       -> return ()
 361         _:_         -> do anyCharC_;               argument eol
 362
 363 nested :: Char -> Parser ()
 364 nested c = do argument (== '\n'); charC_ c
 365
 366 cComment :: Parser ()
 367 cComment = do
 368     s <- lookAheadC
 369     case s of
 370         []        -> return ()
 371         '*':'/':_ -> do any2CharsC_
 372         _:_       -> do anyCharC_; cComment
 373
 374 cString :: Char -> Parser ()
 375 cString quote = do
 376     s <- lookAheadC
 377     case s of
 378         []               -> return ()
 379         c:_ | c == quote -> anyCharC_
 380         '\\':_:_         -> do any2CharsC_; cString quote
 381         _:_              -> do anyCharC_; cString quote
 382
 383 ------------------------------------------------------------------------
 384 -- Output the output files.
 385
 386 output :: [Flag] -> String -> [Token] -> IO ()
 387 output flags name toks = let
 388     baseName = case reverse name of
 389         'c':base -> reverse base
 390         _        -> name++".hs"
 391     cProgName = baseName++"_make.c"
 392     oProgName = baseName++"_make.o"
 393     progName  = baseName++"_make"
 394     outHsName = baseName
 395     outHName  = baseName++".h"
 396     outCName  = baseName++".c"
 397
 398     execProgName = case progName of
 399         '/':_ -> progName
 400         _     -> "./"++progName
 401
 402     specials = [(pos, key, arg) | Special pos key arg <- toks]
 403
 404     needsC = any (\(_, key, _) -> key == "def") specials
 405     needsH = needsC
 406
 407     includeGuard = map fixChar outHName
 408         where
 409         fixChar c | isAlphaNum c = toUpper c
 410                   | otherwise    = '_'
 411
 412     in do
 413
 414     compiler <- case [c | Compiler c <- flags] of
 415         []  -> return "ghc"
 416         [c] -> return c
 417         _   -> onlyOne "compiler"
 418     linker <- case [l | Linker l <- flags] of
 419         []  -> return defaultCompiler
 420         [l] -> return l
 421         _   -> onlyOne "linker"
 422
 423     writeFile cProgName $
 424         concat ["#include \""++t++"\"\n" | Template t <- flags]++
 425         concat ["#include "++f++"\n"     | Include  f <- flags]++
 426         outHeaderCProg specials++
 427         "\nint main (void)\n{\n"++
 428         outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
 429         outHsLine (SourcePos name 0)++
 430         concatMap outTokenHs toks++
 431         "    return 0;\n}\n"
 432
 433     unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess
 434
 435     compilerStatus <- system $
 436         compiler++
 437         " -c"++
 438         concat [" "++f | CompFlag f <- flags]++
 439         " "++cProgName++
 440         " -o "++oProgName
 441     case compilerStatus of
 442         e@(ExitFailure _) -> exitWith e
 443         _                 -> return ()
 444     removeFile cProgName
 445
 446     linkerStatus <- system $
 447         linker++
 448         concat [" "++f | LinkFlag f <- flags]++
 449         " "++oProgName++
 450         " -o "++progName
 451     case linkerStatus of
 452         e@(ExitFailure _) -> exitWith e
 453         _                 -> return ()
 454     removeFile oProgName
 455
 456     system (execProgName++" >"++outHsName)
 457     removeFile progName
 458
 459     when needsH $ writeFile outHName $
 460         "#ifndef "++includeGuard++"\n\
 461         \#define "++includeGuard++"\n\
 462         \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 463         \#include <Rts.h>\n\
 464         \#endif\n\
 465         \#include <HsFFI.h>\n\
 466         \#if __NHC__\n\
 467         \#undef HsChar\n\
 468         \#define HsChar int\n\
 469         \#endif\n"++
 470         concat ["#include "++n++"\n" | Include n <- flags]++
 471         concatMap outTokenH specials++
 472         "#endif\n"
 473
 474     when needsC $ writeFile outCName $
 475         "#include \""++outHName++"\"\n"++
 476         concatMap outTokenC specials
 477
 478 onlyOne :: String -> IO a
 479 onlyOne what = do
 480     putStrLn ("Only one "++what++" may be specified")
 481     exitFailure
 482
 483 outHeaderCProg :: [(SourcePos, String, String)] -> String
 484 outHeaderCProg =
 485     concatMap $ \(pos, key, arg) -> case key of
 486         "include"           -> outCLine pos++"#include "++arg++"\n"
 487         "define"            -> outCLine pos++"#define "++arg++"\n"
 488         "undef"             -> outCLine pos++"#undef "++arg++"\n"
 489         "def"               -> case arg of
 490             's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
 491             't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
 492             _ -> ""
 493         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 494         "let"               -> case break (== '=') arg of
 495             (_,      "")     -> ""
 496             (header, _:body) -> case break isSpace header of
 497                 (name, args) ->
 498                     outCLine pos++
 499                     "#define hsc_"++name++"("++dropWhile isSpace args++") \
 500                     \printf ("++joinLines body++");\n"
 501         _ -> ""
 502     where
 503     joinLines = concat . intersperse " \\\n" . lines
 504
 505 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
 506 outHeaderHs flags inH toks =
 507     "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 508     \    printf (\"{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d #-}\\n\", \
 509     \__GLASGOW_HASKELL__);\n\
 510     \#endif\n"++
 511     includeH++
 512     concatMap outSpecial toks
 513     where
 514     outSpecial (pos, key, arg) = case key of
 515         "include" -> case inH of
 516             Nothing -> outOption ("-#include "++arg)
 517             Just _  -> ""
 518         "define" -> case inH of
 519             Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
 520             _ -> ""
 521         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 522         _ -> ""
 523     goodForOptD arg = case arg of
 524         ""              -> True
 525         c:_ | isSpace c -> True
 526         '(':_           -> False
 527         _:s             -> goodForOptD s
 528     toOptD arg = case break isSpace arg of
 529         (name, "")      -> name
 530         (name, _:value) -> name++'=':dropWhile isSpace value
 531     includeH = concat [
 532         outOption ("-#include "++name++"")
 533         | name <- case inH of
 534             Nothing   -> [name | Include name <- flags]
 535             Just name -> ["\""++name++"\""]]
 536     outOption s = "    printf (\"{-# OPTIONS %s #-}\\n\", \""++
 537                   showCString s++"\");\n"
 538
 539 outTokenHs :: Token -> String
 540 outTokenHs (Text pos text) =
 541     case break (== '\n') text of
 542         (all, [])       -> outText all
 543         (first, _:rest) ->
 544             outText (first++"\n")++
 545             outHsLine pos++
 546             outText rest
 547     where
 548     outText s = "    fputs (\""++showCString s++"\", stdout);\n"
 549 outTokenHs (Special pos key arg) =
 550     case key of
 551         "include"           -> ""
 552         "define"            -> ""
 553         "undef"             -> ""
 554         "def"               -> ""
 555         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 556         "let"               -> ""
 557         "enum"              -> outCLine pos++outEnum arg
 558         _                   -> outCLine pos++"    hsc_"++key++" ("++arg++");\n"
 559
 560 outEnum :: String -> String
 561 outEnum arg =
 562     case break (== ',') arg of
 563         (_, [])        -> ""
 564         (t, _:afterT) -> case break (== ',') afterT of
 565             (f, afterF) -> let
 566                 enums []    = ""
 567                 enums (_:s) = case break (== ',') s of
 568                     (enum, rest) -> let
 569                         this = case break (== '=') $ dropWhile isSpace enum of
 570                             (name, []) ->
 571                                 "    hsc_enum ("++t++", "++f++", \
 572                                 \hsc_haskellize (\""++name++"\"), "++
 573                                 name++");\n"
 574                             (hsName, _:cName) ->
 575                                 "    hsc_enum ("++t++", "++f++", \
 576                                 \printf (\"%s\", \""++hsName++"\"), "++
 577                                 cName++");\n"
 578                         in this++enums rest
 579                 in enums afterF
 580
 581 outTokenH :: (SourcePos, String, String) -> String
 582 outTokenH (pos, key, arg) =
 583     case key of
 584         "include" -> outCLine pos++"#include "++arg++"\n"
 585         "define"  -> outCLine pos++"#define " ++arg++"\n"
 586         "undef"   -> outCLine pos++"#undef "  ++arg++"\n"
 587         "def"     -> outCLine pos++case arg of
 588             's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 589             't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 590             'i':'n':'l':'i':'n':'e':' ':_ ->
 591                 "#ifdef __GNUC__\n\
 592                 \extern\n\
 593                 \#endif\n"++
 594                 arg++"\n"
 595             _ -> "extern "++header++";\n"
 596             where header = takeWhile (\c -> c /= '{' && c /= '=') arg
 597         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 598         _ -> ""
 599
 600 outTokenC :: (SourcePos, String, String) -> String
 601 outTokenC (pos, key, arg) =
 602     case key of
 603         "def" -> case arg of
 604             's':'t':'r':'u':'c':'t':' ':_ -> ""
 605             't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
 606             'i':'n':'l':'i':'n':'e':' ':_ ->
 607                 outCLine pos++
 608                 "#ifndef __GNUC__\n\
 609                 \extern\n\
 610                 \#endif\n"++
 611                 header++
 612                 "\n#ifndef __GNUC__\n\
 613                 \;\n\
 614                 \#else\n"++
 615                 body++
 616                 "\n#endif\n"
 617             _ -> outCLine pos++arg++"\n"
 618             where (header, body) = span (\c -> c /= '{' && c /= '=') arg
 619         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 620         _ -> ""
 621
 622 conditional :: String -> Bool
 623 conditional "if"      = True
 624 conditional "ifdef"   = True
 625 conditional "ifndef"  = True
 626 conditional "elif"    = True
 627 conditional "else"    = True
 628 conditional "endif"   = True
 629 conditional "error"   = True
 630 conditional "warning" = True
 631 conditional _         = False
 632
 633 outCLine :: SourcePos -> String
 634 outCLine (SourcePos name line) =
 635     "# "++show line++" \""++showCString (basename name)++"\"\n"
 636
 637 outHsLine :: SourcePos -> String
 638 outHsLine (SourcePos name line) =
 639     "    hsc_line ("++show (line + 1)++", \""++
 640     showCString (basename name)++"\");\n"
 641
 642 basename :: String -> String
 643 basename s = case break (== '/') s of
 644     (name, [])      -> name
 645     (_,     _:rest) -> basename rest
 646
 647 showCString :: String -> String
 648 showCString = concatMap showCChar
 649     where
 650     showCChar '\"' = "\\\""
 651     showCChar '\'' = "\\\'"
 652     showCChar '?'  = "\\?"
 653     showCChar '\\' = "\\\\"
 654     showCChar c | c >= ' ' && c <= '~' = [c]
 655     showCChar '\a' = "\\a"
 656     showCChar '\b' = "\\b"
 657     showCChar '\f' = "\\f"
 658     showCChar '\n' = "\\n\"\n           \""
 659     showCChar '\r' = "\\r"
 660     showCChar '\t' = "\\t"
 661     showCChar '\v' = "\\v"
 662     showCChar c    = ['\\',
 663                       intToDigit (ord c `quot` 64),
 664                       intToDigit (ord c `quot` 8 `mod` 8),
 665                       intToDigit (ord c          `mod` 8)]