ghc/utils/hsc2hs/Main.hs

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