ghc/utils/hsc2hs/Main.hs

   1 ------------------------------------------------------------------------
   2 -- $Id: Main.hs,v 1.35 2002/01/17 08:37:57 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_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         outHName     = outDir++outBase++"_hsc.h"
 449         outCName     = outDir++outBase++"_hsc.c"
 450
 451     let execProgName
 452             | null outDir = '.':pathSep:progName
 453             | otherwise   = progName
 454
 455     let specials = [(pos, key, arg) | Special pos key arg <- toks]
 456
 457     let needsC = any (\(_, key, _) -> key == "def") specials
 458         needsH = needsC
 459
 460     let includeGuard = map fixChar outHName
 461             where
 462             fixChar c | isAlphaNum c = toUpper c
 463                       | otherwise    = '_'
 464
 465     compiler <- case [c | Compiler c <- flags] of
 466         []  -> return "ghc"
 467         [c] -> return c
 468         _   -> onlyOne "compiler"
 469
 470     linker <- case [l | Linker l <- flags] of
 471         []  -> return cGCC
 472         [l] -> return l
 473         _   -> onlyOne "linker"
 474
 475     writeFile cProgName $
 476         concatMap outFlagHeaderCProg flags++
 477         concatMap outHeaderCProg specials++
 478         "\nint main (void)\n{\n"++
 479         outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
 480         outHsLine (SourcePos name 0)++
 481         concatMap outTokenHs toks++
 482         "    return 0;\n}\n"
 483
 484     unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess
 485
 486     compilerStatus <- system $
 487         compiler++
 488         " -c"++
 489         concat [" "++f | CompFlag f <- flags]++
 490         " "++cProgName++
 491         " -o "++oProgName
 492     case compilerStatus of
 493         e@(ExitFailure _) -> exitWith e
 494         _                 -> return ()
 495     removeFile cProgName
 496
 497     linkerStatus <- system $
 498         linker++
 499         concat [" "++f | LinkFlag f <- flags]++
 500         " "++oProgName++
 501         " -o "++progName
 502     case linkerStatus of
 503         e@(ExitFailure _) -> exitWith e
 504         _                 -> return ()
 505     removeFile oProgName
 506
 507     system (execProgName++" >"++outName)
 508     removeFile progName
 509
 510     when needsH $ writeFile outHName $
 511         "#ifndef "++includeGuard++"\n\
 512         \#define "++includeGuard++"\n\
 513         \#if " ++
 514         "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 515         \#include <Rts.h>\n\
 516         \#endif\n\
 517         \#include <HsFFI.h>\n\
 518         \#if __NHC__\n\
 519         \#undef HsChar\n\
 520         \#define HsChar int\n\
 521         \#endif\n"++
 522         concatMap outFlagH flags++
 523         concatMap outTokenH specials++
 524         "#endif\n"
 525
 526     when needsC $ writeFile outCName $
 527         "#include \""++outHName++"\"\n"++
 528         concatMap outTokenC specials
 529
 530 onlyOne :: String -> IO a
 531 onlyOne what = do
 532     putStrLn ("Only one "++what++" may be specified")
 533     exitFailure
 534
 535 outFlagHeaderCProg :: Flag -> String
 536 outFlagHeaderCProg (Template t)          = "#include \""++t++"\"\n"
 537 outFlagHeaderCProg (Include  f)          = "#include "++f++"\n"
 538 outFlagHeaderCProg (Define   n Nothing)  = "#define "++n++"\n"
 539 outFlagHeaderCProg (Define   n (Just v)) = "#define "++n++" "++v++"\n"
 540 outFlagHeaderCProg _                     = ""
 541
 542 outHeaderCProg :: (SourcePos, String, String) -> String
 543 outHeaderCProg (pos, key, arg) = case key of
 544     "include"           -> outCLine pos++"#include "++arg++"\n"
 545     "define"            -> outCLine pos++"#define "++arg++"\n"
 546     "undef"             -> outCLine pos++"#undef "++arg++"\n"
 547     "def"               -> case arg of
 548         's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
 549         't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
 550         _ -> ""
 551     _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 552     "let"               -> case break (== '=') arg of
 553         (_,      "")     -> ""
 554         (header, _:body) -> case break isSpace header of
 555             (name, args) ->
 556                 outCLine pos++
 557                 "#define hsc_"++name++"("++dropWhile isSpace args++") \
 558                 \printf ("++joinLines body++");\n"
 559     _ -> ""
 560     where
 561     joinLines = concat . intersperse " \\\n" . lines
 562
 563 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
 564 outHeaderHs flags inH toks =
 565     "#if " ++
 566     "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 567     \    printf (\"{-# OPTIONS -optc-D" ++
 568     "__GLASGOW_HASKELL__=%d #-}\\n\", \
 569     \__GLASGOW_HASKELL__);\n\
 570     \#endif\n"++
 571     case inH of
 572         Nothing -> concatMap outFlag flags++concatMap outSpecial toks
 573         Just f  -> outOption ("-#include \""++f++"\"")
 574     where
 575     outFlag (Include f)          = outOption ("-#include "++f)
 576     outFlag (Define  n Nothing)  = outOption ("-optc-D"++n)
 577     outFlag (Define  n (Just v)) = outOption ("-optc-D"++n++"="++v)
 578     outFlag _                    = ""
 579     outSpecial (pos, key, arg) = case key of
 580         "include"                  -> outOption ("-#include "++arg)
 581         "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
 582                  | otherwise       -> ""
 583         _ | conditional key        -> outCLine pos++"#"++key++" "++arg++"\n"
 584         _                          -> ""
 585     goodForOptD arg = case arg of
 586         ""              -> True
 587         c:_ | isSpace c -> True
 588         '(':_           -> False
 589         _:s             -> goodForOptD s
 590     toOptD arg = case break isSpace arg of
 591         (name, "")      -> name
 592         (name, _:value) -> name++'=':dropWhile isSpace value
 593     outOption s = "    printf (\"{-# OPTIONS %s #-}\\n\", \""++
 594                   showCString s++"\");\n"
 595
 596 outTokenHs :: Token -> String
 597 outTokenHs (Text pos text) =
 598     case break (== '\n') text of
 599         (all, [])       -> outText all
 600         (first, _:rest) ->
 601             outText (first++"\n")++
 602             outHsLine pos++
 603             outText rest
 604     where
 605     outText s = "    fputs (\""++showCString s++"\", stdout);\n"
 606 outTokenHs (Special pos key arg) =
 607     case key of
 608         "include"           -> ""
 609         "define"            -> ""
 610         "undef"             -> ""
 611         "def"               -> ""
 612         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 613         "let"               -> ""
 614         "enum"              -> outCLine pos++outEnum arg
 615         _                   -> outCLine pos++"    hsc_"++key++" ("++arg++");\n"
 616
 617 outEnum :: String -> String
 618 outEnum arg =
 619     case break (== ',') arg of
 620         (_, [])        -> ""
 621         (t, _:afterT) -> case break (== ',') afterT of
 622             (f, afterF) -> let
 623                 enums []    = ""
 624                 enums (_:s) = case break (== ',') s of
 625                     (enum, rest) -> let
 626                         this = case break (== '=') $ dropWhile isSpace enum of
 627                             (name, []) ->
 628                                 "    hsc_enum ("++t++", "++f++", \
 629                                 \hsc_haskellize (\""++name++"\"), "++
 630                                 name++");\n"
 631                             (hsName, _:cName) ->
 632                                 "    hsc_enum ("++t++", "++f++", \
 633                                 \printf (\"%s\", \""++hsName++"\"), "++
 634                                 cName++");\n"
 635                         in this++enums rest
 636                 in enums afterF
 637
 638 outFlagH :: Flag -> String
 639 outFlagH (Include  f)          = "#include "++f++"\n"
 640 outFlagH (Define   n Nothing)  = "#define "++n++"\n"
 641 outFlagH (Define   n (Just v)) = "#define "++n++" "++v++"\n"
 642 outFlagH _                     = ""
 643
 644 outTokenH :: (SourcePos, String, String) -> String
 645 outTokenH (pos, key, arg) =
 646     case key of
 647         "include" -> outCLine pos++"#include "++arg++"\n"
 648         "define"  -> outCLine pos++"#define " ++arg++"\n"
 649         "undef"   -> outCLine pos++"#undef "  ++arg++"\n"
 650         "def"     -> outCLine pos++case arg of
 651             's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 652             't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 653             'i':'n':'l':'i':'n':'e':' ':_ ->
 654                 "#ifdef __GNUC__\n\
 655                 \extern\n\
 656                 \#endif\n"++
 657                 arg++"\n"
 658             _ -> "extern "++header++";\n"
 659             where header = takeWhile (\c -> c /= '{' && c /= '=') arg
 660         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 661         _ -> ""
 662
 663 outTokenC :: (SourcePos, String, String) -> String
 664 outTokenC (pos, key, arg) =
 665     case key of
 666         "def" -> case arg of
 667             's':'t':'r':'u':'c':'t':' ':_ -> ""
 668             't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
 669             'i':'n':'l':'i':'n':'e':' ':arg' ->
 670                 case span (\c -> c /= '{' && c /= '=') arg' of
 671                 (header, body) ->
 672                     outCLine pos++
 673                     "#ifndef __GNUC__\n\
 674                     \extern inline\n\
 675                     \#endif\n"++
 676                     header++
 677                     "\n#ifndef __GNUC__\n\
 678                     \;\n\
 679                     \#else\n"++
 680                     body++
 681                     "\n#endif\n"
 682             _ -> outCLine pos++arg++"\n"
 683         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 684         _ -> ""
 685
 686 conditional :: String -> Bool
 687 conditional "if"      = True
 688 conditional "ifdef"   = True
 689 conditional "ifndef"  = True
 690 conditional "elif"    = True
 691 conditional "else"    = True
 692 conditional "endif"   = True
 693 conditional "error"   = True
 694 conditional "warning" = True
 695 conditional _         = False
 696
 697 outCLine :: SourcePos -> String
 698 outCLine (SourcePos name line) =
 699     "# "++show line++" \""++showCString (snd (splitName name))++"\"\n"
 700
 701 outHsLine :: SourcePos -> String
 702 outHsLine (SourcePos name line) =
 703     "    hsc_line ("++show (line + 1)++", \""++
 704     showCString (snd (splitName name))++"\");\n"
 705
 706 showCString :: String -> String
 707 showCString = concatMap showCChar
 708     where
 709     showCChar '\"' = "\\\""
 710     showCChar '\'' = "\\\'"
 711     showCChar '?'  = "\\?"
 712     showCChar '\\' = "\\\\"
 713     showCChar c | c >= ' ' && c <= '~' = [c]
 714     showCChar '\a' = "\\a"
 715     showCChar '\b' = "\\b"
 716     showCChar '\f' = "\\f"
 717     showCChar '\n' = "\\n\"\n           \""
 718     showCChar '\r' = "\\r"
 719     showCChar '\t' = "\\t"
 720     showCChar '\v' = "\\v"
 721     showCChar c    = ['\\',
 722                       intToDigit (ord c `quot` 64),
 723                       intToDigit (ord c `quot` 8 `mod` 8),
 724                       intToDigit (ord c          `mod` 8)]