ghc/utils/hsc2hs/Main.hs

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