ghc/utils/hsc2hs/Main.hs

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