ghc/utils/hsc2hs/Main.hs

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