ghc/utils/hsc2hs/Main.hs

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