ghc/utils/hsc2hs/Main.hs

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