ghc/utils/hsc2hs/Main.hs

   1 ------------------------------------------------------------------------
   2 -- $Id: Main.hs,v 1.39 2002/05/29 22:32:49 sof 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_HOST_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_HOST_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_HOST_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     progStatus <- system (execProgName++" >"++outName)
 520     removeFile progName
 521     case progStatus of
 522         e@(ExitFailure _) -> exitWith e
 523         _                 -> return ()
 524
 525     when needsH $ writeFile outHName $
 526         "#ifndef "++includeGuard++"\n\
 527         \#define "++includeGuard++"\n\
 528         \#if " ++
 529         "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 530         \#include <Rts.h>\n\
 531         \#endif\n\
 532         \#include <HsFFI.h>\n\
 533         \#if __NHC__\n\
 534         \#undef HsChar\n\
 535         \#define HsChar int\n\
 536         \#endif\n"++
 537         concatMap outFlagH flags++
 538         concatMap outTokenH specials++
 539         "#endif\n"
 540
 541     when needsC $ writeFile outCName $
 542         "#include \""++outHFile++"\"\n"++
 543         concatMap outTokenC specials
 544         -- NB. outHFile not outHName; works better when processed
 545         -- by gcc or mkdependC.
 546
 547 onlyOne :: String -> IO a
 548 onlyOne what = do
 549     putStrLn ("Only one "++what++" may be specified")
 550     exitFailure
 551
 552 outFlagHeaderCProg :: Flag -> String
 553 outFlagHeaderCProg (Template t)          = "#include \""++t++"\"\n"
 554 outFlagHeaderCProg (Include  f)          = "#include "++f++"\n"
 555 outFlagHeaderCProg (Define   n Nothing)  = "#define "++n++"\n"
 556 outFlagHeaderCProg (Define   n (Just v)) = "#define "++n++" "++v++"\n"
 557 outFlagHeaderCProg _                     = ""
 558
 559 outHeaderCProg :: (SourcePos, String, String) -> String
 560 outHeaderCProg (pos, key, arg) = case key of
 561     "include"           -> outCLine pos++"#include "++arg++"\n"
 562     "define"            -> outCLine pos++"#define "++arg++"\n"
 563     "undef"             -> outCLine pos++"#undef "++arg++"\n"
 564     "def"               -> case arg of
 565         's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
 566         't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
 567         _ -> ""
 568     _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 569     "let"               -> case break (== '=') arg of
 570         (_,      "")     -> ""
 571         (header, _:body) -> case break isSpace header of
 572             (name, args) ->
 573                 outCLine pos++
 574                 "#define hsc_"++name++"("++dropWhile isSpace args++") \
 575                 \printf ("++joinLines body++");\n"
 576     _ -> ""
 577     where
 578     joinLines = concat . intersperse " \\\n" . lines
 579
 580 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
 581 outHeaderHs flags inH toks =
 582     "#if " ++
 583     "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 584     \    printf (\"{-# OPTIONS -optc-D" ++
 585     "__GLASGOW_HASKELL__=%d #-}\\n\", \
 586     \__GLASGOW_HASKELL__);\n\
 587     \#endif\n"++
 588     case inH of
 589         Nothing -> concatMap outFlag flags++concatMap outSpecial toks
 590         Just f  -> outOption ("-#include \""++f++"\"")
 591     where
 592     outFlag (Include f)          = outOption ("-#include "++f)
 593     outFlag (Define  n Nothing)  = outOption ("-optc-D"++n)
 594     outFlag (Define  n (Just v)) = outOption ("-optc-D"++n++"="++v)
 595     outFlag _                    = ""
 596     outSpecial (pos, key, arg) = case key of
 597         "include"                  -> outOption ("-#include "++arg)
 598         "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
 599                  | otherwise       -> ""
 600         _ | conditional key        -> outCLine pos++"#"++key++" "++arg++"\n"
 601         _                          -> ""
 602     goodForOptD arg = case arg of
 603         ""              -> True
 604         c:_ | isSpace c -> True
 605         '(':_           -> False
 606         _:s             -> goodForOptD s
 607     toOptD arg = case break isSpace arg of
 608         (name, "")      -> name
 609         (name, _:value) -> name++'=':dropWhile isSpace value
 610     outOption s = "    printf (\"{-# OPTIONS %s #-}\\n\", \""++
 611                   showCString s++"\");\n"
 612
 613 outTokenHs :: Token -> String
 614 outTokenHs (Text pos text) =
 615     case break (== '\n') text of
 616         (all, [])       -> outText all
 617         (first, _:rest) ->
 618             outText (first++"\n")++
 619             outHsLine pos++
 620             outText rest
 621     where
 622     outText s = "    fputs (\""++showCString s++"\", stdout);\n"
 623 outTokenHs (Special pos key arg) =
 624     case key of
 625         "include"           -> ""
 626         "define"            -> ""
 627         "undef"             -> ""
 628         "def"               -> ""
 629         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 630         "let"               -> ""
 631         "enum"              -> outCLine pos++outEnum arg
 632         _                   -> outCLine pos++"    hsc_"++key++" ("++arg++");\n"
 633
 634 outEnum :: String -> String
 635 outEnum arg =
 636     case break (== ',') arg of
 637         (_, [])        -> ""
 638         (t, _:afterT) -> case break (== ',') afterT of
 639             (f, afterF) -> let
 640                 enums []    = ""
 641                 enums (_:s) = case break (== ',') s of
 642                     (enum, rest) -> let
 643                         this = case break (== '=') $ dropWhile isSpace enum of
 644                             (name, []) ->
 645                                 "    hsc_enum ("++t++", "++f++", \
 646                                 \hsc_haskellize (\""++name++"\"), "++
 647                                 name++");\n"
 648                             (hsName, _:cName) ->
 649                                 "    hsc_enum ("++t++", "++f++", \
 650                                 \printf (\"%s\", \""++hsName++"\"), "++
 651                                 cName++");\n"
 652                         in this++enums rest
 653                 in enums afterF
 654
 655 outFlagH :: Flag -> String
 656 outFlagH (Include  f)          = "#include "++f++"\n"
 657 outFlagH (Define   n Nothing)  = "#define "++n++"\n"
 658 outFlagH (Define   n (Just v)) = "#define "++n++" "++v++"\n"
 659 outFlagH _                     = ""
 660
 661 outTokenH :: (SourcePos, String, String) -> String
 662 outTokenH (pos, key, arg) =
 663     case key of
 664         "include" -> outCLine pos++"#include "++arg++"\n"
 665         "define"  -> outCLine pos++"#define " ++arg++"\n"
 666         "undef"   -> outCLine pos++"#undef "  ++arg++"\n"
 667         "def"     -> outCLine pos++case arg of
 668             's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 669             't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 670             'i':'n':'l':'i':'n':'e':' ':_ ->
 671                 "#ifdef __GNUC__\n\
 672                 \extern\n\
 673                 \#endif\n"++
 674                 arg++"\n"
 675             _ -> "extern "++header++";\n"
 676             where header = takeWhile (\c -> c /= '{' && c /= '=') arg
 677         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 678         _ -> ""
 679
 680 outTokenC :: (SourcePos, String, String) -> String
 681 outTokenC (pos, key, arg) =
 682     case key of
 683         "def" -> case arg of
 684             's':'t':'r':'u':'c':'t':' ':_ -> ""
 685             't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
 686             'i':'n':'l':'i':'n':'e':' ':arg' ->
 687                 case span (\c -> c /= '{' && c /= '=') arg' of
 688                 (header, body) ->
 689                     outCLine pos++
 690                     "#ifndef __GNUC__\n\
 691                     \extern inline\n\
 692                     \#endif\n"++
 693                     header++
 694                     "\n#ifndef __GNUC__\n\
 695                     \;\n\
 696                     \#else\n"++
 697                     body++
 698                     "\n#endif\n"
 699             _ -> outCLine pos++arg++"\n"
 700         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 701         _ -> ""
 702
 703 conditional :: String -> Bool
 704 conditional "if"      = True
 705 conditional "ifdef"   = True
 706 conditional "ifndef"  = True
 707 conditional "elif"    = True
 708 conditional "else"    = True
 709 conditional "endif"   = True
 710 conditional "error"   = True
 711 conditional "warning" = True
 712 conditional _         = False
 713
 714 outCLine :: SourcePos -> String
 715 outCLine (SourcePos name line) =
 716     "# "++show line++" \""++showCString (snd (splitName name))++"\"\n"
 717
 718 outHsLine :: SourcePos -> String
 719 outHsLine (SourcePos name line) =
 720     "    hsc_line ("++show (line + 1)++", \""++
 721     showCString (snd (splitName name))++"\");\n"
 722
 723 showCString :: String -> String
 724 showCString = concatMap showCChar
 725     where
 726     showCChar '\"' = "\\\""
 727     showCChar '\'' = "\\\'"
 728     showCChar '?'  = "\\?"
 729     showCChar '\\' = "\\\\"
 730     showCChar c | c >= ' ' && c <= '~' = [c]
 731     showCChar '\a' = "\\a"
 732     showCChar '\b' = "\\b"
 733     showCChar '\f' = "\\f"
 734     showCChar '\n' = "\\n\"\n           \""
 735     showCChar '\r' = "\\r"
 736     showCChar '\t' = "\\t"
 737     showCChar '\v' = "\\v"
 738     showCChar c    = ['\\',
 739                       intToDigit (ord c `quot` 64),
 740                       intToDigit (ord c `quot` 8 `mod` 8),
 741                       intToDigit (ord c          `mod` 8)]