ghc/utils/hsc2hs/Main.hs

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