ghc/utils/hsc2hs/Main.hs

   1 ------------------------------------------------------------------------
   2 -- $Id: Main.hs,v 1.25 2001/03/05 00:07:23 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 {-# INLINE lookAhead #-}
 141 lookAhead :: Parser String
 142 lookAhead = Parser $ \pos s -> Success pos [] s s
 143
 144 {-# INLINE satisfy #-}
 145 satisfy :: (Char -> Bool) -> Parser Char
 146 satisfy p =
 147     Parser $ \pos s -> case s of
 148         c:cs | p c -> Success (updatePos pos c) [c] cs c
 149         _          -> Failure pos "Bad character"
 150
 151 char_ :: Char -> Parser ()
 152 char_ c = do
 153     satisfy (== c) `message` (show c++" expected")
 154     return ()
 155
 156 anyChar_ :: Parser ()
 157 anyChar_ = do
 158     satisfy (const True) `message` "Unexpected end of file"
 159     return ()
 160
 161 any2Chars_ :: Parser ()
 162 any2Chars_ = anyChar_ >> anyChar_
 163
 164 many :: Parser a -> Parser [a]
 165 many p = many1 p `mplus` return []
 166
 167 many1 :: Parser a -> Parser [a]
 168 many1 p = liftM2 (:) p (many p)
 169
 170 many_ :: Parser a -> Parser ()
 171 many_ p = many1_ p `mplus` return ()
 172
 173 many1_ :: Parser a -> Parser ()
 174 many1_ p = p >> many_ p
 175
 176 manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String
 177 manySatisfy  = many  . satisfy
 178 manySatisfy1 = many1 . satisfy
 179
 180 manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser ()
 181 manySatisfy_  = many_  . satisfy
 182 manySatisfy1_ = many1_ . satisfy
 183
 184 ------------------------------------------------------------------------
 185 -- Parser of hsc syntax.
 186
 187 data Token
 188     = Text    SourcePos String
 189     | Special SourcePos String String
 190
 191 parser :: Parser [Token]
 192 parser = do
 193     pos <- getPos
 194     t <- catchOutput_ text
 195     s <- lookAhead
 196     rest <- case s of
 197         []  -> return []
 198         _:_ -> liftM2 (:) (special `fakeOutput` []) parser
 199     return (if null t then rest else Text pos t : rest)
 200
 201 text :: Parser ()
 202 text = do
 203     s <- lookAhead
 204     case s of
 205         []        -> return ()
 206         c:_ | isAlpha c || c == '_' -> do
 207             anyChar_
 208             manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'')
 209             text
 210         c:_ | isHsSymbol c -> do
 211             symb <- catchOutput_ (manySatisfy_ isHsSymbol)
 212             case symb of
 213                 "#" -> return ()
 214                 '-':'-':symb' | all (== '-') symb' -> do
 215                     return () `fakeOutput` symb
 216                     manySatisfy_ (/= '\n')
 217                     text
 218                 _ -> do
 219                     return () `fakeOutput` unescapeHashes symb
 220                     text
 221         '\"':_    -> do anyChar_; hsString '\"'; text
 222         '\'':_    -> do anyChar_; hsString '\''; text
 223         '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text
 224         _:_       -> do anyChar_; text
 225
 226 hsString :: Char -> Parser ()
 227 hsString quote = do
 228     s <- lookAhead
 229     case s of
 230         []               -> return ()
 231         c:_ | c == quote -> anyChar_
 232         '\\':c:_
 233             | isSpace c  -> do
 234                 anyChar_
 235                 manySatisfy_ isSpace
 236                 char_ '\\' `mplus` return ()
 237                 hsString quote
 238             | otherwise  -> do any2Chars_; hsString quote
 239         _:_              -> do anyChar_; hsString quote
 240
 241 hsComment :: Parser ()
 242 hsComment = do
 243     s <- lookAhead
 244     case s of
 245         []        -> return ()
 246         '-':'}':_ -> any2Chars_
 247         '{':'-':_ -> do any2Chars_; hsComment; hsComment
 248         _:_       -> do anyChar_; hsComment
 249
 250 linePragma :: Parser ()
 251 linePragma = do
 252     char_ '#'
 253     manySatisfy_ isSpace
 254     satisfy (\c -> c == 'L' || c == 'l')
 255     satisfy (\c -> c == 'I' || c == 'i')
 256     satisfy (\c -> c == 'N' || c == 'n')
 257     satisfy (\c -> c == 'E' || c == 'e')
 258     manySatisfy1_ isSpace
 259     line <- liftM read $ manySatisfy1 isDigit
 260     manySatisfy1_ isSpace
 261     char_ '\"'
 262     name <- manySatisfy (/= '\"')
 263     char_ '\"'
 264     manySatisfy_ isSpace
 265     char_ '#'
 266     char_ '-'
 267     char_ '}'
 268     setPos (SourcePos name (line - 1))
 269
 270 isHsSymbol :: Char -> Bool
 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; isHsSymbol '@' = True; isHsSymbol '\\' = True
 276 isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-'  = True
 277 isHsSymbol '~' = True
 278 isHsSymbol _   = False
 279
 280 unescapeHashes :: String -> String
 281 unescapeHashes []          = []
 282 unescapeHashes ('#':'#':s) = '#' : unescapeHashes s
 283 unescapeHashes (c:s)       = c   : unescapeHashes s
 284
 285 {-# INLINE lookAheadC #-}
 286 lookAheadC :: Parser String
 287 lookAheadC = liftM joinLines lookAhead
 288     where
 289     joinLines []            = []
 290     joinLines ('\\':'\n':s) = joinLines s
 291     joinLines (c:s)         = c : joinLines s
 292
 293 {-# INLINE satisfyC #-}
 294 satisfyC :: (Char -> Bool) -> Parser Char
 295 satisfyC p = do
 296     s <- lookAhead
 297     case s of
 298         '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p
 299         _           -> satisfy p
 300
 301 charC_ :: Char -> Parser ()
 302 charC_ c = do
 303     satisfyC (== c) `message` (show c++" expected")
 304     return ()
 305
 306 anyCharC_ :: Parser ()
 307 anyCharC_ = do
 308     satisfyC (const True) `message` "Unexpected end of file"
 309     return ()
 310
 311 any2CharsC_ :: Parser ()
 312 any2CharsC_ = anyCharC_ >> anyCharC_
 313
 314 manySatisfyC :: (Char -> Bool) -> Parser String
 315 manySatisfyC = many . satisfyC
 316
 317 manySatisfyC_ :: (Char -> Bool) -> Parser ()
 318 manySatisfyC_ = many_ . satisfyC
 319
 320 special :: Parser Token
 321 special = do
 322     manySatisfyC_ (\c -> isSpace c && c /= '\n')
 323     s <- lookAheadC
 324     case s of
 325         '{':_ -> do
 326             anyCharC_
 327             manySatisfyC_ isSpace
 328             sp <- keyArg (== '\n')
 329             charC_ '}'
 330             return sp
 331         _ -> keyArg (const False)
 332
 333 keyArg :: (Char -> Bool) -> Parser Token
 334 keyArg eol = do
 335     pos <- getPos
 336     key <- keyword `message` "hsc keyword or '{' expected"
 337     manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c')
 338     arg <- catchOutput_ (argument eol)
 339     return (Special pos key arg)
 340
 341 keyword :: Parser String
 342 keyword = do
 343     c  <- satisfyC (\c' -> isAlpha c' || c' == '_')
 344     cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_')
 345     return (c:cs)
 346
 347 argument :: (Char -> Bool) -> Parser ()
 348 argument eol = do
 349     s <- lookAheadC
 350     case s of
 351         []          -> return ()
 352         c:_ | eol c -> do anyCharC_;               argument eol
 353         '\n':_      -> return ()
 354         '\"':_      -> do anyCharC_; cString '\"'; argument eol
 355         '\'':_      -> do anyCharC_; cString '\''; argument eol
 356         '(':_       -> do anyCharC_; nested ')';   argument eol
 357         ')':_       -> return ()
 358         '/':'*':_   -> do any2CharsC_; cComment;   argument eol
 359         '/':'/':_   -> do
 360             any2CharsC_; manySatisfyC_ (/= '\n');  argument eol
 361         '[':_       -> do anyCharC_; nested ']';   argument eol
 362         ']':_       -> return ()
 363         '{':_       -> do anyCharC_; nested '}';   argument eol
 364         '}':_       -> return ()
 365         _:_         -> do anyCharC_;               argument eol
 366
 367 nested :: Char -> Parser ()
 368 nested c = do argument (== '\n'); charC_ c
 369
 370 cComment :: Parser ()
 371 cComment = do
 372     s <- lookAheadC
 373     case s of
 374         []        -> return ()
 375         '*':'/':_ -> do any2CharsC_
 376         _:_       -> do anyCharC_; cComment
 377
 378 cString :: Char -> Parser ()
 379 cString quote = do
 380     s <- lookAheadC
 381     case s of
 382         []               -> return ()
 383         c:_ | c == quote -> anyCharC_
 384         '\\':_:_         -> do any2CharsC_; cString quote
 385         _:_              -> do anyCharC_; cString quote
 386
 387 ------------------------------------------------------------------------
 388 -- Output the output files.
 389
 390 output :: [Flag] -> String -> [Token] -> IO ()
 391 output flags name toks = let
 392     baseName = case reverse name of
 393         'c':base -> reverse base
 394         _        -> name++".hs"
 395     cProgName = baseName++"_make.c"
 396     oProgName = baseName++"_make.o"
 397     progName  = baseName++"_make"
 398     outHsName = baseName
 399     outHName  = baseName++".h"
 400     outCName  = baseName++".c"
 401
 402     execProgName = case progName of
 403         '/':_ -> progName
 404         _     -> "./"++progName
 405
 406     specials = [(pos, key, arg) | Special pos key arg <- toks]
 407
 408     needsC = any (\(_, key, _) -> key == "def") specials
 409     needsH = needsC
 410
 411     includeGuard = map fixChar outHName
 412         where
 413         fixChar c | isAlphaNum c = toUpper c
 414                   | otherwise    = '_'
 415
 416     in do
 417
 418     compiler <- case [c | Compiler c <- flags] of
 419         []  -> return "ghc"
 420         [c] -> return c
 421         _   -> onlyOne "compiler"
 422     linker <- case [l | Linker l <- flags] of
 423         []  -> return defaultCompiler
 424         [l] -> return l
 425         _   -> onlyOne "linker"
 426
 427     writeFile cProgName $
 428         concat ["#include \""++t++"\"\n" | Template t <- flags]++
 429         concat ["#include "++f++"\n"     | Include  f <- flags]++
 430         outHeaderCProg specials++
 431         "\nint main (void)\n{\n"++
 432         outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
 433         outHsLine (SourcePos name 0)++
 434         concatMap outTokenHs toks++
 435         "    return 0;\n}\n"
 436
 437     unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess
 438
 439     compilerStatus <- system $
 440         compiler++
 441         " -c"++
 442         concat [" "++f | CompFlag f <- flags]++
 443         " "++cProgName++
 444         " -o "++oProgName
 445     case compilerStatus of
 446         e@(ExitFailure _) -> exitWith e
 447         _                 -> return ()
 448     removeFile cProgName
 449
 450     linkerStatus <- system $
 451         linker++
 452         concat [" "++f | LinkFlag f <- flags]++
 453         " "++oProgName++
 454         " -o "++progName
 455     case linkerStatus of
 456         e@(ExitFailure _) -> exitWith e
 457         _                 -> return ()
 458     removeFile oProgName
 459
 460     system (execProgName++" >"++outHsName)
 461     removeFile progName
 462
 463     when needsH $ writeFile outHName $
 464         "#ifndef "++includeGuard++"\n\
 465         \#define "++includeGuard++"\n\
 466         \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 467         \#include <Rts.h>\n\
 468         \#endif\n\
 469         \#include <HsFFI.h>\n\
 470         \#if __NHC__\n\
 471         \#undef HsChar\n\
 472         \#define HsChar int\n\
 473         \#endif\n"++
 474         concat ["#include "++n++"\n" | Include n <- flags]++
 475         concatMap outTokenH specials++
 476         "#endif\n"
 477
 478     when needsC $ writeFile outCName $
 479         "#include \""++outHName++"\"\n"++
 480         concatMap outTokenC specials
 481
 482 onlyOne :: String -> IO a
 483 onlyOne what = do
 484     putStrLn ("Only one "++what++" may be specified")
 485     exitFailure
 486
 487 outHeaderCProg :: [(SourcePos, String, String)] -> String
 488 outHeaderCProg =
 489     concatMap $ \(pos, key, arg) -> case key of
 490         "include"           -> outCLine pos++"#include "++arg++"\n"
 491         "define"            -> outCLine pos++"#define "++arg++"\n"
 492         "undef"             -> outCLine pos++"#undef "++arg++"\n"
 493         "def"               -> case arg of
 494             's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
 495             't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
 496             _ -> ""
 497         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 498         "let"               -> case break (== '=') arg of
 499             (_,      "")     -> ""
 500             (header, _:body) -> case break isSpace header of
 501                 (name, args) ->
 502                     outCLine pos++
 503                     "#define hsc_"++name++"("++dropWhile isSpace args++") \
 504                     \printf ("++joinLines body++");\n"
 505         _ -> ""
 506     where
 507     joinLines = concat . intersperse " \\\n" . lines
 508
 509 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
 510 outHeaderHs flags inH toks =
 511     "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 512     \    printf (\"{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d #-}\\n\", \
 513     \__GLASGOW_HASKELL__);\n\
 514     \#endif\n"++
 515     includeH++
 516     concatMap outSpecial toks
 517     where
 518     outSpecial (pos, key, arg) = case key of
 519         "include" -> case inH of
 520             Nothing -> outOption ("-#include "++arg)
 521             Just _  -> ""
 522         "define" -> case inH of
 523             Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
 524             _ -> ""
 525         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 526         _ -> ""
 527     goodForOptD arg = case arg of
 528         ""              -> True
 529         c:_ | isSpace c -> True
 530         '(':_           -> False
 531         _:s             -> goodForOptD s
 532     toOptD arg = case break isSpace arg of
 533         (name, "")      -> name
 534         (name, _:value) -> name++'=':dropWhile isSpace value
 535     includeH = concat [
 536         outOption ("-#include "++name++"")
 537         | name <- case inH of
 538             Nothing   -> [name | Include name <- flags]
 539             Just name -> ["\""++name++"\""]]
 540     outOption s = "    printf (\"{-# OPTIONS %s #-}\\n\", \""++
 541                   showCString s++"\");\n"
 542
 543 outTokenHs :: Token -> String
 544 outTokenHs (Text pos text) =
 545     case break (== '\n') text of
 546         (all, [])       -> outText all
 547         (first, _:rest) ->
 548             outText (first++"\n")++
 549             outHsLine pos++
 550             outText rest
 551     where
 552     outText s = "    fputs (\""++showCString s++"\", stdout);\n"
 553 outTokenHs (Special pos key arg) =
 554     case key of
 555         "include"           -> ""
 556         "define"            -> ""
 557         "undef"             -> ""
 558         "def"               -> ""
 559         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 560         "let"               -> ""
 561         "enum"              -> outCLine pos++outEnum arg
 562         _                   -> outCLine pos++"    hsc_"++key++" ("++arg++");\n"
 563
 564 outEnum :: String -> String
 565 outEnum arg =
 566     case break (== ',') arg of
 567         (_, [])        -> ""
 568         (t, _:afterT) -> case break (== ',') afterT of
 569             (f, afterF) -> let
 570                 enums []    = ""
 571                 enums (_:s) = case break (== ',') s of
 572                     (enum, rest) -> let
 573                         this = case break (== '=') $ dropWhile isSpace enum of
 574                             (name, []) ->
 575                                 "    hsc_enum ("++t++", "++f++", \
 576                                 \hsc_haskellize (\""++name++"\"), "++
 577                                 name++");\n"
 578                             (hsName, _:cName) ->
 579                                 "    hsc_enum ("++t++", "++f++", \
 580                                 \printf (\"%s\", \""++hsName++"\"), "++
 581                                 cName++");\n"
 582                         in this++enums rest
 583                 in enums afterF
 584
 585 outTokenH :: (SourcePos, String, String) -> String
 586 outTokenH (pos, key, arg) =
 587     case key of
 588         "include" -> outCLine pos++"#include "++arg++"\n"
 589         "define"  -> outCLine pos++"#define " ++arg++"\n"
 590         "undef"   -> outCLine pos++"#undef "  ++arg++"\n"
 591         "def"     -> outCLine pos++case arg of
 592             's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 593             't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 594             'i':'n':'l':'i':'n':'e':' ':_ ->
 595                 "#ifdef __GNUC__\n\
 596                 \extern\n\
 597                 \#endif\n"++
 598                 arg++"\n"
 599             _ -> "extern "++header++";\n"
 600             where header = takeWhile (\c -> c /= '{' && c /= '=') arg
 601         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 602         _ -> ""
 603
 604 outTokenC :: (SourcePos, String, String) -> String
 605 outTokenC (pos, key, arg) =
 606     case key of
 607         "def" -> case arg of
 608             's':'t':'r':'u':'c':'t':' ':_ -> ""
 609             't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
 610             'i':'n':'l':'i':'n':'e':' ':_ ->
 611                 outCLine pos++
 612                 "#ifndef __GNUC__\n\
 613                 \extern\n\
 614                 \#endif\n"++
 615                 header++
 616                 "\n#ifndef __GNUC__\n\
 617                 \;\n\
 618                 \#else\n"++
 619                 body++
 620                 "\n#endif\n"
 621             _ -> outCLine pos++arg++"\n"
 622             where (header, body) = span (\c -> c /= '{' && c /= '=') arg
 623         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 624         _ -> ""
 625
 626 conditional :: String -> Bool
 627 conditional "if"      = True
 628 conditional "ifdef"   = True
 629 conditional "ifndef"  = True
 630 conditional "elif"    = True
 631 conditional "else"    = True
 632 conditional "endif"   = True
 633 conditional "error"   = True
 634 conditional "warning" = True
 635 conditional _         = False
 636
 637 outCLine :: SourcePos -> String
 638 outCLine (SourcePos name line) =
 639     "# "++show line++" \""++showCString (basename name)++"\"\n"
 640
 641 outHsLine :: SourcePos -> String
 642 outHsLine (SourcePos name line) =
 643     "    hsc_line ("++show (line + 1)++", \""++
 644     showCString (basename name)++"\");\n"
 645
 646 basename :: String -> String
 647 basename s = case break (== '/') s of
 648     (name, [])      -> name
 649     (_,     _:rest) -> basename rest
 650
 651 showCString :: String -> String
 652 showCString = concatMap showCChar
 653     where
 654     showCChar '\"' = "\\\""
 655     showCChar '\'' = "\\\'"
 656     showCChar '?'  = "\\?"
 657     showCChar '\\' = "\\\\"
 658     showCChar c | c >= ' ' && c <= '~' = [c]
 659     showCChar '\a' = "\\a"
 660     showCChar '\b' = "\\b"
 661     showCChar '\f' = "\\f"
 662     showCChar '\n' = "\\n\"\n           \""
 663     showCChar '\r' = "\\r"
 664     showCChar '\t' = "\\t"
 665     showCChar '\v' = "\\v"
 666     showCChar c    = ['\\',
 667                       intToDigit (ord c `quot` 64),
 668                       intToDigit (ord c `quot` 8 `mod` 8),
 669                       intToDigit (ord c          `mod` 8)]