ghc/utils/hsc2hs/Main.hs

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