ghc/utils/hsc2hs/Main.hs

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