ghc/utils/hsc2hs/Main.hs

   1 ------------------------------------------------------------------------
   2 -- $Id: Main.hs,v 1.27 2001/03/29 00:01:18 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 HsMake*.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 -- Write the output files.
 385
 386 splitName :: String -> (String, String)
 387 splitName name =
 388     case break (== '/') name of
 389         (file, [])       -> ([], file)
 390         (dir,  sep:rest) -> (dir++sep:restDir, restFile)
 391             where
 392             (restDir, restFile) = splitName rest
 393
 394 splitExt :: String -> (String, String)
 395 splitExt name =
 396     case break (== '.') name of
 397         (base, [])         -> (base, [])
 398         (base, sepRest@(sep:rest))
 399             | null restExt -> (base,               sepRest)
 400             | otherwise    -> (base++sep:restBase, restExt)
 401             where
 402             (restBase, restExt) = splitExt rest
 403
 404 output :: [Flag] -> String -> [Token] -> IO ()
 405 output flags name toks = let
 406     (dir,  file) = splitName name
 407     (base, ext)  = splitExt  file
 408     cProgName    = dir++"HsMake"++base++".c"
 409     oProgName    = dir++"HsMake"++base++".o"
 410     progName     = dir++"HsMake"++base
 411     outHsName
 412         | not (null ext) && last ext == 'c' = dir++base++init ext
 413         | ext == ".hs"                      = dir++base++"_out.hs"
 414         | otherwise                         = dir++base++".hs"
 415     outHName     = dir++"Hs"++base++".h"
 416     outCName     = dir++"Hs"++base++".c"
 417
 418     execProgName
 419         | null dir  = "./"++progName
 420         | otherwise = progName
 421
 422     specials = [(pos, key, arg) | Special pos key arg <- toks]
 423
 424     needsC = any (\(_, key, _) -> key == "def") specials
 425     needsH = needsC
 426
 427     includeGuard = map fixChar outHName
 428         where
 429         fixChar c | isAlphaNum c = toUpper c
 430                   | otherwise    = '_'
 431
 432     in do
 433
 434     compiler <- case [c | Compiler c <- flags] of
 435         []  -> return "ghc"
 436         [c] -> return c
 437         _   -> onlyOne "compiler"
 438     linker <- case [l | Linker l <- flags] of
 439         []  -> return defaultCompiler
 440         [l] -> return l
 441         _   -> onlyOne "linker"
 442
 443     writeFile cProgName $
 444         concat ["#include \""++t++"\"\n" | Template t <- flags]++
 445         concat ["#include "++f++"\n"     | Include  f <- flags]++
 446         outHeaderCProg specials++
 447         "\nint main (void)\n{\n"++
 448         outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
 449         outHsLine (SourcePos name 0)++
 450         concatMap outTokenHs toks++
 451         "    return 0;\n}\n"
 452
 453     unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess
 454
 455     compilerStatus <- system $
 456         compiler++
 457         " -c"++
 458         concat [" "++f | CompFlag f <- flags]++
 459         " "++cProgName++
 460         " -o "++oProgName
 461     case compilerStatus of
 462         e@(ExitFailure _) -> exitWith e
 463         _                 -> return ()
 464     removeFile cProgName
 465
 466     linkerStatus <- system $
 467         linker++
 468         concat [" "++f | LinkFlag f <- flags]++
 469         " "++oProgName++
 470         " -o "++progName
 471     case linkerStatus of
 472         e@(ExitFailure _) -> exitWith e
 473         _                 -> return ()
 474     removeFile oProgName
 475
 476     system (execProgName++" >"++outHsName)
 477     removeFile progName
 478
 479     when needsH $ writeFile outHName $
 480         "#ifndef "++includeGuard++"\n\
 481         \#define "++includeGuard++"\n\
 482         \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 483         \#include <Rts.h>\n\
 484         \#endif\n\
 485         \#include <HsFFI.h>\n\
 486         \#if __NHC__\n\
 487         \#undef HsChar\n\
 488         \#define HsChar int\n\
 489         \#endif\n"++
 490         concat ["#include "++n++"\n" | Include n <- flags]++
 491         concatMap outTokenH specials++
 492         "#endif\n"
 493
 494     when needsC $ writeFile outCName $
 495         "#include \""++outHName++"\"\n"++
 496         concatMap outTokenC specials
 497
 498 onlyOne :: String -> IO a
 499 onlyOne what = do
 500     putStrLn ("Only one "++what++" may be specified")
 501     exitFailure
 502
 503 outHeaderCProg :: [(SourcePos, String, String)] -> String
 504 outHeaderCProg =
 505     concatMap $ \(pos, key, arg) -> case key of
 506         "include"           -> outCLine pos++"#include "++arg++"\n"
 507         "define"            -> outCLine pos++"#define "++arg++"\n"
 508         "undef"             -> outCLine pos++"#undef "++arg++"\n"
 509         "def"               -> case arg of
 510             's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
 511             't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
 512             _ -> ""
 513         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 514         "let"               -> case break (== '=') arg of
 515             (_,      "")     -> ""
 516             (header, _:body) -> case break isSpace header of
 517                 (name, args) ->
 518                     outCLine pos++
 519                     "#define hsc_"++name++"("++dropWhile isSpace args++") \
 520                     \printf ("++joinLines body++");\n"
 521         _ -> ""
 522     where
 523     joinLines = concat . intersperse " \\\n" . lines
 524
 525 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
 526 outHeaderHs flags inH toks =
 527     "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 528     \    printf (\"{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d #-}\\n\", \
 529     \__GLASGOW_HASKELL__);\n\
 530     \#endif\n"++
 531     includeH++
 532     concatMap outSpecial toks
 533     where
 534     outSpecial (pos, key, arg) = case key of
 535         "include" -> case inH of
 536             Nothing -> outOption ("-#include "++arg)
 537             Just _  -> ""
 538         "define" -> case inH of
 539             Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
 540             _ -> ""
 541         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 542         _ -> ""
 543     goodForOptD arg = case arg of
 544         ""              -> True
 545         c:_ | isSpace c -> True
 546         '(':_           -> False
 547         _:s             -> goodForOptD s
 548     toOptD arg = case break isSpace arg of
 549         (name, "")      -> name
 550         (name, _:value) -> name++'=':dropWhile isSpace value
 551     includeH = concat [
 552         outOption ("-#include "++name++"")
 553         | name <- case inH of
 554             Nothing   -> [name | Include name <- flags]
 555             Just name -> ["\""++name++"\""]]
 556     outOption s = "    printf (\"{-# OPTIONS %s #-}\\n\", \""++
 557                   showCString s++"\");\n"
 558
 559 outTokenHs :: Token -> String
 560 outTokenHs (Text pos text) =
 561     case break (== '\n') text of
 562         (all, [])       -> outText all
 563         (first, _:rest) ->
 564             outText (first++"\n")++
 565             outHsLine pos++
 566             outText rest
 567     where
 568     outText s = "    fputs (\""++showCString s++"\", stdout);\n"
 569 outTokenHs (Special pos key arg) =
 570     case key of
 571         "include"           -> ""
 572         "define"            -> ""
 573         "undef"             -> ""
 574         "def"               -> ""
 575         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 576         "let"               -> ""
 577         "enum"              -> outCLine pos++outEnum arg
 578         _                   -> outCLine pos++"    hsc_"++key++" ("++arg++");\n"
 579
 580 outEnum :: String -> String
 581 outEnum arg =
 582     case break (== ',') arg of
 583         (_, [])        -> ""
 584         (t, _:afterT) -> case break (== ',') afterT of
 585             (f, afterF) -> let
 586                 enums []    = ""
 587                 enums (_:s) = case break (== ',') s of
 588                     (enum, rest) -> let
 589                         this = case break (== '=') $ dropWhile isSpace enum of
 590                             (name, []) ->
 591                                 "    hsc_enum ("++t++", "++f++", \
 592                                 \hsc_haskellize (\""++name++"\"), "++
 593                                 name++");\n"
 594                             (hsName, _:cName) ->
 595                                 "    hsc_enum ("++t++", "++f++", \
 596                                 \printf (\"%s\", \""++hsName++"\"), "++
 597                                 cName++");\n"
 598                         in this++enums rest
 599                 in enums afterF
 600
 601 outTokenH :: (SourcePos, String, String) -> String
 602 outTokenH (pos, key, arg) =
 603     case key of
 604         "include" -> outCLine pos++"#include "++arg++"\n"
 605         "define"  -> outCLine pos++"#define " ++arg++"\n"
 606         "undef"   -> outCLine pos++"#undef "  ++arg++"\n"
 607         "def"     -> outCLine pos++case arg of
 608             's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 609             't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 610             'i':'n':'l':'i':'n':'e':' ':_ ->
 611                 "#ifdef __GNUC__\n\
 612                 \extern\n\
 613                 \#endif\n"++
 614                 arg++"\n"
 615             _ -> "extern "++header++";\n"
 616             where header = takeWhile (\c -> c /= '{' && c /= '=') arg
 617         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 618         _ -> ""
 619
 620 outTokenC :: (SourcePos, String, String) -> String
 621 outTokenC (pos, key, arg) =
 622     case key of
 623         "def" -> case arg of
 624             's':'t':'r':'u':'c':'t':' ':_ -> ""
 625             't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
 626             'i':'n':'l':'i':'n':'e':' ':_ ->
 627                 outCLine pos++
 628                 "#ifndef __GNUC__\n\
 629                 \extern\n\
 630                 \#endif\n"++
 631                 header++
 632                 "\n#ifndef __GNUC__\n\
 633                 \;\n\
 634                 \#else\n"++
 635                 body++
 636                 "\n#endif\n"
 637             _ -> outCLine pos++arg++"\n"
 638             where (header, body) = span (\c -> c /= '{' && c /= '=') arg
 639         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 640         _ -> ""
 641
 642 conditional :: String -> Bool
 643 conditional "if"      = True
 644 conditional "ifdef"   = True
 645 conditional "ifndef"  = True
 646 conditional "elif"    = True
 647 conditional "else"    = True
 648 conditional "endif"   = True
 649 conditional "error"   = True
 650 conditional "warning" = True
 651 conditional _         = False
 652
 653 outCLine :: SourcePos -> String
 654 outCLine (SourcePos name line) =
 655     "# "++show line++" \""++showCString (snd (splitName name))++"\"\n"
 656
 657 outHsLine :: SourcePos -> String
 658 outHsLine (SourcePos name line) =
 659     "    hsc_line ("++show (line + 1)++", \""++
 660     showCString (snd (splitName name))++"\");\n"
 661
 662 showCString :: String -> String
 663 showCString = concatMap showCChar
 664     where
 665     showCChar '\"' = "\\\""
 666     showCChar '\'' = "\\\'"
 667     showCChar '?'  = "\\?"
 668     showCChar '\\' = "\\\\"
 669     showCChar c | c >= ' ' && c <= '~' = [c]
 670     showCChar '\a' = "\\a"
 671     showCChar '\b' = "\\b"
 672     showCChar '\f' = "\\f"
 673     showCChar '\n' = "\\n\"\n           \""
 674     showCChar '\r' = "\\r"
 675     showCChar '\t' = "\\t"
 676     showCChar '\v' = "\\v"
 677     showCChar c    = ['\\',
 678                       intToDigit (ord c `quot` 64),
 679                       intToDigit (ord c `quot` 8 `mod` 8),
 680                       intToDigit (ord c          `mod` 8)]