ghc/utils/hsc2hs/Main.hs

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