ghc/utils/hsc2hs/Main.hs

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