utils/hsc2hs/Main.hs

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