ghc/utils/hsc2hs/Main.hs

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