ghc/utils/hsc2hs/Main.hs

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