ghc/utils/hsc2hs/Main.hs

   1 {-# OPTIONS -fffi #-}
   2
   3 ------------------------------------------------------------------------
   4 -- $Id: Main.hs,v 1.53 2004/02/15 12:20:26 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 || __NHC__ >= 114
  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 || __NHC__ >= 114
  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"
 498 #if defined(mingw32_HOST_OS)
 499 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
 500 -- via GHC has changed a few times, so this seems to be the only way...  :-P * * *
 501                           ++ ".exe"
 502 #endif
 503         outHFile     = outBase++"_hsc.h"
 504         outHName     = outDir++outHFile
 505         outCName     = outDir++outBase++"_hsc.c"
 506
 507         beVerbose    = any (\ x -> case x of { Verbose{} -> True; _ -> False}) flags
 508
 509     let execProgName
 510             | null outDir = dosifyPath ("./" ++ progName)
 511             | otherwise   = progName
 512
 513     let specials = [(pos, key, arg) | Special pos key arg <- toks]
 514
 515     let needsC = any (\(_, key, _) -> key == "def") specials
 516         needsH = needsC
 517
 518     let includeGuard = map fixChar outHName
 519             where
 520             fixChar c | isAlphaNum c = toUpper c
 521                       | otherwise    = '_'
 522
 523           -- try locating GHC..on Win32, look in the vicinity of hsc2hs.
 524         locateGhc def = do
 525             mb <- getExecDir "bin/hsc2hs.exe"
 526             case mb of
 527               Nothing -> return def
 528               Just x  -> do
 529                  let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
 530                  flg <- doesFileExist ghc_path
 531                  if flg
 532                   then return ghc_path
 533                   else return def
 534
 535     compiler <- case [c | Compiler c <- flags] of
 536         []  -> locateGhc "ghc"
 537         [c] -> return c
 538         _   -> onlyOne "compiler"
 539
 540     linker <- case [l | Linker l <- flags] of
 541         []  -> locateGhc compiler
 542         [l] -> return l
 543         _   -> onlyOne "linker"
 544
 545     writeFile cProgName $
 546         concatMap outFlagHeaderCProg flags++
 547         concatMap outHeaderCProg specials++
 548         "\nint main (int argc, char *argv [])\n{\n"++
 549         outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
 550         outHsLine (SourcePos name 0)++
 551         concatMap outTokenHs toks++
 552         "    return 0;\n}\n"
 553
 554     unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess
 555
 556
 557
 558     compilerStatus <- systemL beVerbose $
 559         compiler++
 560         " -c"++
 561         concat [" "++f | CompFlag f <- flags]++
 562         " "++cProgName++
 563         " -o "++oProgName
 564     case compilerStatus of
 565         e@(ExitFailure _) -> exitWith e
 566         _                 -> return ()
 567     removeFile cProgName
 568
 569     linkerStatus <- systemL beVerbose $
 570         linker++
 571         concat [" "++f | LinkFlag f <- flags]++
 572         " "++oProgName++
 573         " -o "++progName
 574     case linkerStatus of
 575         e@(ExitFailure _) -> exitWith e
 576         _                 -> return ()
 577     removeFile oProgName
 578
 579     progStatus <- systemL beVerbose (execProgName++" >"++outName)
 580     removeFile progName
 581     case progStatus of
 582         e@(ExitFailure _) -> exitWith e
 583         _                 -> return ()
 584
 585     when needsH $ writeFile outHName $
 586         "#ifndef "++includeGuard++"\n\
 587         \#define "++includeGuard++"\n\
 588         \#if " ++
 589         "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 590         \#include <Rts.h>\n\
 591         \#endif\n\
 592         \#include <HsFFI.h>\n\
 593         \#if __NHC__\n\
 594         \#undef HsChar\n\
 595         \#define HsChar int\n\
 596         \#endif\n"++
 597         concatMap outFlagH flags++
 598         concatMap outTokenH specials++
 599         "#endif\n"
 600
 601     when needsC $ writeFile outCName $
 602         "#include \""++outHFile++"\"\n"++
 603         concatMap outTokenC specials
 604         -- NB. outHFile not outHName; works better when processed
 605         -- by gcc or mkdependC.
 606
 607 systemL :: Bool -> String -> IO ExitCode
 608 systemL flg s = do
 609   when flg (hPutStrLn stderr ("Executing: " ++ s))
 610   system s
 611
 612 onlyOne :: String -> IO a
 613 onlyOne what = die ("Only one "++what++" may be specified\n")
 614
 615 outFlagHeaderCProg :: Flag -> String
 616 outFlagHeaderCProg (Template t)          = "#include \""++t++"\"\n"
 617 outFlagHeaderCProg (Include  f)          = "#include "++f++"\n"
 618 outFlagHeaderCProg (Define   n Nothing)  = "#define "++n++"\n"
 619 outFlagHeaderCProg (Define   n (Just v)) = "#define "++n++" "++v++"\n"
 620 outFlagHeaderCProg _                     = ""
 621
 622 outHeaderCProg :: (SourcePos, String, String) -> String
 623 outHeaderCProg (pos, key, arg) = case key of
 624     "include"           -> outCLine pos++"#include "++arg++"\n"
 625     "define"            -> outCLine pos++"#define "++arg++"\n"
 626     "undef"             -> outCLine pos++"#undef "++arg++"\n"
 627     "def"               -> case arg of
 628         's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
 629         't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
 630         _ -> ""
 631     _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 632     "let"               -> case break (== '=') arg of
 633         (_,      "")     -> ""
 634         (header, _:body) -> case break isSpace header of
 635             (name, args) ->
 636                 outCLine pos++
 637                 "#define hsc_"++name++"("++dropWhile isSpace args++") \
 638                 \printf ("++joinLines body++");\n"
 639     _ -> ""
 640     where
 641     joinLines = concat . intersperse " \\\n" . lines
 642
 643 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
 644 outHeaderHs flags inH toks =
 645     "#if " ++
 646     "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 647     \    printf (\"{-# OPTIONS -optc-D" ++
 648     "__GLASGOW_HASKELL__=%d #-}\\n\", \
 649     \__GLASGOW_HASKELL__);\n\
 650     \#endif\n"++
 651     case inH of
 652         Nothing -> concatMap outFlag flags++concatMap outSpecial toks
 653         Just f  -> outOption ("-#include \""++f++"\"")
 654     where
 655     outFlag (Include f)          = outOption ("-#include "++f)
 656     outFlag (Define  n Nothing)  = outOption ("-optc-D"++n)
 657     outFlag (Define  n (Just v)) = outOption ("-optc-D"++n++"="++v)
 658     outFlag _                    = ""
 659     outSpecial (pos, key, arg) = case key of
 660         "include"                  -> outOption ("-#include "++arg)
 661         "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
 662                  | otherwise       -> ""
 663         _ | conditional key        -> outCLine pos++"#"++key++" "++arg++"\n"
 664         _                          -> ""
 665     goodForOptD arg = case arg of
 666         ""              -> True
 667         c:_ | isSpace c -> True
 668         '(':_           -> False
 669         _:s             -> goodForOptD s
 670     toOptD arg = case break isSpace arg of
 671         (name, "")      -> name
 672         (name, _:value) -> name++'=':dropWhile isSpace value
 673     outOption s = "    printf (\"{-# OPTIONS %s #-}\\n\", \""++
 674                   showCString s++"\");\n"
 675
 676 outTokenHs :: Token -> String
 677 outTokenHs (Text pos txt) =
 678     case break (== '\n') txt of
 679         (allTxt, [])       -> outText allTxt
 680         (first, _:rest) ->
 681             outText (first++"\n")++
 682             outHsLine pos++
 683             outText rest
 684     where
 685     outText s = "    fputs (\""++showCString s++"\", stdout);\n"
 686 outTokenHs (Special pos key arg) =
 687     case key of
 688         "include"           -> ""
 689         "define"            -> ""
 690         "undef"             -> ""
 691         "def"               -> ""
 692         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 693         "let"               -> ""
 694         "enum"              -> outCLine pos++outEnum arg
 695         _                   -> outCLine pos++"    hsc_"++key++" ("++arg++");\n"
 696
 697 outEnum :: String -> String
 698 outEnum arg =
 699     case break (== ',') arg of
 700         (_, [])        -> ""
 701         (t, _:afterT) -> case break (== ',') afterT of
 702             (f, afterF) -> let
 703                 enums []    = ""
 704                 enums (_:s) = case break (== ',') s of
 705                     (enum, rest) -> let
 706                         this = case break (== '=') $ dropWhile isSpace enum of
 707                             (name, []) ->
 708                                 "    hsc_enum ("++t++", "++f++", \
 709                                 \hsc_haskellize (\""++name++"\"), "++
 710                                 name++");\n"
 711                             (hsName, _:cName) ->
 712                                 "    hsc_enum ("++t++", "++f++", \
 713                                 \printf (\"%s\", \""++hsName++"\"), "++
 714                                 cName++");\n"
 715                         in this++enums rest
 716                 in enums afterF
 717
 718 outFlagH :: Flag -> String
 719 outFlagH (Include  f)          = "#include "++f++"\n"
 720 outFlagH (Define   n Nothing)  = "#define "++n++"\n"
 721 outFlagH (Define   n (Just v)) = "#define "++n++" "++v++"\n"
 722 outFlagH _                     = ""
 723
 724 outTokenH :: (SourcePos, String, String) -> String
 725 outTokenH (pos, key, arg) =
 726     case key of
 727         "include" -> outCLine pos++"#include "++arg++"\n"
 728         "define"  -> outCLine pos++"#define " ++arg++"\n"
 729         "undef"   -> outCLine pos++"#undef "  ++arg++"\n"
 730         "def"     -> outCLine pos++case arg of
 731             's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 732             't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 733             'i':'n':'l':'i':'n':'e':' ':_ ->
 734                 "#ifdef __GNUC__\n\
 735                 \extern\n\
 736                 \#endif\n"++
 737                 arg++"\n"
 738             _ -> "extern "++header++";\n"
 739             where header = takeWhile (\c -> c /= '{' && c /= '=') arg
 740         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 741         _ -> ""
 742
 743 outTokenC :: (SourcePos, String, String) -> String
 744 outTokenC (pos, key, arg) =
 745     case key of
 746         "def" -> case arg of
 747             's':'t':'r':'u':'c':'t':' ':_ -> ""
 748             't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
 749             'i':'n':'l':'i':'n':'e':' ':arg' ->
 750                 case span (\c -> c /= '{' && c /= '=') arg' of
 751                 (header, body) ->
 752                     outCLine pos++
 753                     "#ifndef __GNUC__\n\
 754                     \extern inline\n\
 755                     \#endif\n"++
 756                     header++
 757                     "\n#ifndef __GNUC__\n\
 758                     \;\n\
 759                     \#else\n"++
 760                     body++
 761                     "\n#endif\n"
 762             _ -> outCLine pos++arg++"\n"
 763         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 764         _ -> ""
 765
 766 conditional :: String -> Bool
 767 conditional "if"      = True
 768 conditional "ifdef"   = True
 769 conditional "ifndef"  = True
 770 conditional "elif"    = True
 771 conditional "else"    = True
 772 conditional "endif"   = True
 773 conditional "error"   = True
 774 conditional "warning" = True
 775 conditional _         = False
 776
 777 outCLine :: SourcePos -> String
 778 outCLine (SourcePos name line) =
 779     "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
 780
 781 outHsLine :: SourcePos -> String
 782 outHsLine (SourcePos name line) =
 783     "    hsc_line ("++show (line + 1)++", \""++
 784     showCString (snd (splitName name))++"\");\n"
 785
 786 showCString :: String -> String
 787 showCString = concatMap showCChar
 788     where
 789     showCChar '\"' = "\\\""
 790     showCChar '\'' = "\\\'"
 791     showCChar '?'  = "\\?"
 792     showCChar '\\' = "\\\\"
 793     showCChar c | c >= ' ' && c <= '~' = [c]
 794     showCChar '\a' = "\\a"
 795     showCChar '\b' = "\\b"
 796     showCChar '\f' = "\\f"
 797     showCChar '\n' = "\\n\"\n           \""
 798     showCChar '\r' = "\\r"
 799     showCChar '\t' = "\\t"
 800     showCChar '\v' = "\\v"
 801     showCChar c    = ['\\',
 802                       intToDigit (ord c `quot` 64),
 803                       intToDigit (ord c `quot` 8 `mod` 8),
 804                       intToDigit (ord c          `mod` 8)]
 805
 806
 807
 808 -----------------------------------------
 809 --      Cut and pasted from ghc/compiler/SysTools
 810 -- Convert paths foo/baz to foo\baz on Windows
 811
 812 dosifyPath :: String -> String
 813 #if defined(mingw32_HOST_OS)
 814 dosifyPath xs = subst '/' '\\' xs
 815
 816 unDosifyPath :: String -> String
 817 unDosifyPath xs = subst '\\' '/' xs
 818
 819 subst :: Eq a => a -> a -> [a] -> [a]
 820 subst a b ls = map (\ x -> if x == a then b else x) ls
 821
 822 getExecDir :: String -> IO (Maybe String)
 823 -- (getExecDir cmd) returns the directory in which the current
 824 --                  executable, which should be called 'cmd', is running
 825 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
 826 -- you'll get "/a/b/c" back as the result
 827 getExecDir cmd
 828   = allocaArray len $ \buf -> do
 829         ret <- getModuleFileName nullPtr buf len
 830         if ret == 0 then return Nothing
 831                     else do s <- peekCString buf
 832                             return (Just (reverse (drop (length cmd)
 833                                                         (reverse (unDosifyPath s)))))
 834   where
 835     len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
 836
 837 foreign import stdcall unsafe "GetModuleFileNameA"
 838   getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 839
 840 #else
 841 dosifyPath xs = xs
 842
 843 getExecDir :: String -> IO (Maybe String)
 844 getExecDir _ = return Nothing
 845 #endif