ghc/utils/hsc2hs/Main.hs

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