ghc/utils/hsc2hs/Main.hs

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