utils/hsc2hs/Main.hs

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