ghc/utils/hsc2hs/Main.hs

   1 {-# OPTIONS -fffi #-}
   2
   3 ------------------------------------------------------------------------
   4 -- $Id: Main.hs,v 1.57 2004/06/27 20:41:07 panne 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         [] -> if not (null ext) && last ext == 'c'
 482                  then return (dir++base++init ext,  dir, base)
 483                  else
 484                     if ext == ".hs"
 485                        then return (dir++base++"_out.hs", dir, base)
 486                        else return (dir++base++".hs",     dir, base)
 487               where
 488                (dir,  file) = splitName name
 489                (base, ext)  = splitExt  file
 490         [f] -> let
 491             (dir,  file) = splitName f
 492             (base, _)    = splitExt file
 493             in return (f, dir, base)
 494         _ -> onlyOne "output file"
 495
 496     let cProgName    = outDir++outBase++"_hsc_make.c"
 497         oProgName    = outDir++outBase++"_hsc_make.o"
 498         progName     = outDir++outBase++"_hsc_make"
 499 #if defined(mingw32_HOST_OS)
 500 -- This is a real hack, but the quoting mechanism used for calling the C preprocesseor
 501 -- via GHC has changed a few times, so this seems to be the only way...  :-P * * *
 502                           ++ ".exe"
 503 #endif
 504         outHFile     = outBase++"_hsc.h"
 505         outHName     = outDir++outHFile
 506         outCName     = outDir++outBase++"_hsc.c"
 507
 508         beVerbose    = any (\ x -> case x of { Verbose -> True; _ -> False}) flags
 509
 510     let execProgName
 511             | null outDir = dosifyPath ("./" ++ progName)
 512             | otherwise   = progName
 513
 514     let specials = [(pos, key, arg) | Special pos key arg <- toks]
 515
 516     let needsC = any (\(_, key, _) -> key == "def") specials
 517         needsH = needsC
 518
 519     let includeGuard = map fixChar outHName
 520             where
 521             fixChar c | isAlphaNum c = toUpper c
 522                       | otherwise    = '_'
 523
 524         -- Try locating GHC..on Win32, look in the vicinity of hsc2hs.
 525         -- Returns a native-format path
 526         locateGhc def = do
 527             mb <- getExecDir "bin/hsc2hs.exe"
 528             case mb of
 529               Nothing -> return def
 530               Just x  -> do
 531                  let ghc_path = dosifyPath (x ++ "bin/ghc.exe")
 532                  flg <- doesFileExist ghc_path
 533                  if flg
 534                   then return ghc_path
 535                   else return def
 536
 537         -- On a Win32 installation we execute the hsc2hs binary directly,
 538         -- with no --cc flags, so we'll call locateGhc here, which will
 539         -- succeed, via getExecDir.
 540         --
 541         -- On a Unix installation, we'll run the wrapper script hsc2hs.sh
 542         -- (called plain hsc2hs in the installed tree), which will pass
 543         -- a suitable C compiler via --cc
 544         --
 545         -- The in-place installation always uses the wrapper script,
 546         -- (called hsc2hs-inplace, generated from hsc2hs.sh)
 547     compiler <- case [c | Compiler c <- flags] of
 548         []  -> locateGhc "ghc"
 549         [c] -> return c
 550         _   -> onlyOne "compiler"
 551
 552     linker <- case [l | Linker l <- flags] of
 553         []  -> locateGhc compiler
 554         [l] -> return l
 555         _   -> onlyOne "linker"
 556
 557     writeFile cProgName $
 558         concatMap outFlagHeaderCProg flags++
 559         concatMap outHeaderCProg specials++
 560         "\nint main (int argc, char *argv [])\n{\n"++
 561         outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
 562         outHsLine (SourcePos name 0)++
 563         concatMap outTokenHs toks++
 564         "    return 0;\n}\n"
 565
 566     unless (null [() | NoCompile <- flags]) $ exitWith ExitSuccess
 567
 568
 569
 570     compilerStatus <- systemL beVerbose $
 571         compiler++
 572         " -c"++
 573         concat [" "++f | CompFlag f <- flags]++
 574         " "++cProgName++
 575         " -o "++oProgName
 576     case compilerStatus of
 577         e@(ExitFailure _) -> exitWith e
 578         _                 -> return ()
 579     removeFile cProgName
 580
 581     linkerStatus <- systemL beVerbose $
 582         linker++
 583         concat [" "++f | LinkFlag f <- flags]++
 584         " "++oProgName++
 585         " -o "++progName
 586     case linkerStatus of
 587         e@(ExitFailure _) -> exitWith e
 588         _                 -> return ()
 589     removeFile oProgName
 590
 591     progStatus <- systemL beVerbose (execProgName++" >"++outName)
 592     removeFile progName
 593     case progStatus of
 594         e@(ExitFailure _) -> exitWith e
 595         _                 -> return ()
 596
 597     when needsH $ writeFile outHName $
 598         "#ifndef "++includeGuard++"\n\
 599         \#define "++includeGuard++"\n\
 600         \#if " ++
 601         "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 602         \#include <Rts.h>\n\
 603         \#endif\n\
 604         \#include <HsFFI.h>\n\
 605         \#if __NHC__\n\
 606         \#undef HsChar\n\
 607         \#define HsChar int\n\
 608         \#endif\n"++
 609         concatMap outFlagH flags++
 610         concatMap outTokenH specials++
 611         "#endif\n"
 612
 613     when needsC $ writeFile outCName $
 614         "#include \""++outHFile++"\"\n"++
 615         concatMap outTokenC specials
 616         -- NB. outHFile not outHName; works better when processed
 617         -- by gcc or mkdependC.
 618
 619 systemL :: Bool -> String -> IO ExitCode
 620 systemL flg s = do
 621   when flg (hPutStrLn stderr ("Executing: " ++ s))
 622   system s
 623
 624 onlyOne :: String -> IO a
 625 onlyOne what = die ("Only one "++what++" may be specified\n")
 626
 627 outFlagHeaderCProg :: Flag -> String
 628 outFlagHeaderCProg (Template t)          = "#include \""++t++"\"\n"
 629 outFlagHeaderCProg (Include  f)          = "#include "++f++"\n"
 630 outFlagHeaderCProg (Define   n Nothing)  = "#define "++n++"\n"
 631 outFlagHeaderCProg (Define   n (Just v)) = "#define "++n++" "++v++"\n"
 632 outFlagHeaderCProg _                     = ""
 633
 634 outHeaderCProg :: (SourcePos, String, String) -> String
 635 outHeaderCProg (pos, key, arg) = case key of
 636     "include"           -> outCLine pos++"#include "++arg++"\n"
 637     "define"            -> outCLine pos++"#define "++arg++"\n"
 638     "undef"             -> outCLine pos++"#undef "++arg++"\n"
 639     "def"               -> case arg of
 640         's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
 641         't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
 642         _ -> ""
 643     _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 644     "let"               -> case break (== '=') arg of
 645         (_,      "")     -> ""
 646         (header, _:body) -> case break isSpace header of
 647             (name, args) ->
 648                 outCLine pos++
 649                 "#define hsc_"++name++"("++dropWhile isSpace args++") \
 650                 \printf ("++joinLines body++");\n"
 651     _ -> ""
 652    where
 653     joinLines = concat . intersperse " \\\n" . lines
 654
 655 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
 656 outHeaderHs flags inH toks =
 657     "#if " ++
 658     "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 659     \    printf (\"{-# OPTIONS -optc-D" ++
 660     "__GLASGOW_HASKELL__=%d #-}\\n\", \
 661     \__GLASGOW_HASKELL__);\n\
 662     \#endif\n"++
 663     case inH of
 664         Nothing -> concatMap outFlag flags++concatMap outSpecial toks
 665         Just f  -> outOption ("-#include \""++f++"\"")
 666     where
 667     outFlag (Include f)          = outOption ("-#include "++f)
 668     outFlag (Define  n Nothing)  = outOption ("-optc-D"++n)
 669     outFlag (Define  n (Just v)) = outOption ("-optc-D"++n++"="++v)
 670     outFlag _                    = ""
 671     outSpecial (pos, key, arg) = case key of
 672         "include"                  -> outOption ("-#include "++arg)
 673         "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
 674                  | otherwise       -> ""
 675         _ | conditional key        -> outCLine pos++"#"++key++" "++arg++"\n"
 676         _                          -> ""
 677     goodForOptD arg = case arg of
 678         ""              -> True
 679         c:_ | isSpace c -> True
 680         '(':_           -> False
 681         _:s             -> goodForOptD s
 682     toOptD arg = case break isSpace arg of
 683         (name, "")      -> name
 684         (name, _:value) -> name++'=':dropWhile isSpace value
 685     outOption s = "    printf (\"{-# OPTIONS %s #-}\\n\", \""++
 686                   showCString s++"\");\n"
 687
 688 outTokenHs :: Token -> String
 689 outTokenHs (Text pos txt) =
 690     case break (== '\n') txt of
 691         (allTxt, [])       -> outText allTxt
 692         (first, _:rest) ->
 693             outText (first++"\n")++
 694             outHsLine pos++
 695             outText rest
 696     where
 697     outText s = "    fputs (\""++showCString s++"\", stdout);\n"
 698 outTokenHs (Special pos key arg) =
 699     case key of
 700         "include"           -> ""
 701         "define"            -> ""
 702         "undef"             -> ""
 703         "def"               -> ""
 704         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 705         "let"               -> ""
 706         "enum"              -> outCLine pos++outEnum arg
 707         _                   -> outCLine pos++"    hsc_"++key++" ("++arg++");\n"
 708
 709 outEnum :: String -> String
 710 outEnum arg =
 711     case break (== ',') arg of
 712         (_, [])        -> ""
 713         (t, _:afterT) -> case break (== ',') afterT of
 714             (f, afterF) -> let
 715                 enums []    = ""
 716                 enums (_:s) = case break (== ',') s of
 717                     (enum, rest) -> let
 718                         this = case break (== '=') $ dropWhile isSpace enum of
 719                             (name, []) ->
 720                                 "    hsc_enum ("++t++", "++f++", \
 721                                 \hsc_haskellize (\""++name++"\"), "++
 722                                 name++");\n"
 723                             (hsName, _:cName) ->
 724                                 "    hsc_enum ("++t++", "++f++", \
 725                                 \printf (\"%s\", \""++hsName++"\"), "++
 726                                 cName++");\n"
 727                         in this++enums rest
 728                 in enums afterF
 729
 730 outFlagH :: Flag -> String
 731 outFlagH (Include  f)          = "#include "++f++"\n"
 732 outFlagH (Define   n Nothing)  = "#define "++n++"\n"
 733 outFlagH (Define   n (Just v)) = "#define "++n++" "++v++"\n"
 734 outFlagH _                     = ""
 735
 736 outTokenH :: (SourcePos, String, String) -> String
 737 outTokenH (pos, key, arg) =
 738     case key of
 739         "include" -> outCLine pos++"#include "++arg++"\n"
 740         "define"  -> outCLine pos++"#define " ++arg++"\n"
 741         "undef"   -> outCLine pos++"#undef "  ++arg++"\n"
 742         "def"     -> outCLine pos++case arg of
 743             's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 744             't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 745             'i':'n':'l':'i':'n':'e':' ':_ ->
 746                 "#ifdef __GNUC__\n\
 747                 \extern\n\
 748                 \#endif\n"++
 749                 arg++"\n"
 750             _ -> "extern "++header++";\n"
 751           where header = takeWhile (\c -> c /= '{' && c /= '=') arg
 752         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 753         _ -> ""
 754
 755 outTokenC :: (SourcePos, String, String) -> String
 756 outTokenC (pos, key, arg) =
 757     case key of
 758         "def" -> case arg of
 759             's':'t':'r':'u':'c':'t':' ':_ -> ""
 760             't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
 761             'i':'n':'l':'i':'n':'e':' ':arg' ->
 762                 case span (\c -> c /= '{' && c /= '=') arg' of
 763                 (header, body) ->
 764                     outCLine pos++
 765                     "#ifndef __GNUC__\n\
 766                     \extern inline\n\
 767                     \#endif\n"++
 768                     header++
 769                     "\n#ifndef __GNUC__\n\
 770                     \;\n\
 771                     \#else\n"++
 772                     body++
 773                     "\n#endif\n"
 774             _ -> outCLine pos++arg++"\n"
 775         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 776         _ -> ""
 777
 778 conditional :: String -> Bool
 779 conditional "if"      = True
 780 conditional "ifdef"   = True
 781 conditional "ifndef"  = True
 782 conditional "elif"    = True
 783 conditional "else"    = True
 784 conditional "endif"   = True
 785 conditional "error"   = True
 786 conditional "warning" = True
 787 conditional _         = False
 788
 789 outCLine :: SourcePos -> String
 790 outCLine (SourcePos name line) =
 791     "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
 792
 793 outHsLine :: SourcePos -> String
 794 outHsLine (SourcePos name line) =
 795     "    hsc_line ("++show (line + 1)++", \""++
 796     showCString (snd (splitName name))++"\");\n"
 797
 798 showCString :: String -> String
 799 showCString = concatMap showCChar
 800     where
 801     showCChar '\"' = "\\\""
 802     showCChar '\'' = "\\\'"
 803     showCChar '?'  = "\\?"
 804     showCChar '\\' = "\\\\"
 805     showCChar c | c >= ' ' && c <= '~' = [c]
 806     showCChar '\a' = "\\a"
 807     showCChar '\b' = "\\b"
 808     showCChar '\f' = "\\f"
 809     showCChar '\n' = "\\n\"\n           \""
 810     showCChar '\r' = "\\r"
 811     showCChar '\t' = "\\t"
 812     showCChar '\v' = "\\v"
 813     showCChar c    = ['\\',
 814                       intToDigit (ord c `quot` 64),
 815                       intToDigit (ord c `quot` 8 `mod` 8),
 816                       intToDigit (ord c          `mod` 8)]
 817
 818
 819
 820 -----------------------------------------
 821 --      Cut and pasted from ghc/compiler/SysTools
 822 -- Convert paths foo/baz to foo\baz on Windows
 823
 824 dosifyPath :: String -> String
 825 #if defined(mingw32_HOST_OS)
 826 dosifyPath xs = subst '/' '\\' xs
 827
 828 unDosifyPath :: String -> String
 829 unDosifyPath xs = subst '\\' '/' xs
 830
 831 subst :: Eq a => a -> a -> [a] -> [a]
 832 subst a b ls = map (\ x -> if x == a then b else x) ls
 833
 834 getExecDir :: String -> IO (Maybe String)
 835 -- (getExecDir cmd) returns the directory in which the current
 836 --                  executable, which should be called 'cmd', is running
 837 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
 838 -- you'll get "/a/b/c" back as the result
 839 getExecDir cmd
 840   = allocaArray len $ \buf -> do
 841         ret <- getModuleFileName nullPtr buf len
 842         if ret == 0 then return Nothing
 843                     else do s <- peekCString buf
 844                             return (Just (reverse (drop (length cmd)
 845                                                         (reverse (unDosifyPath s)))))
 846   where
 847     len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
 848
 849 foreign import stdcall unsafe "GetModuleFileNameA"
 850   getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 851
 852 #else
 853 dosifyPath xs = xs
 854
 855 getExecDir :: String -> IO (Maybe String)
 856 getExecDir _ = return Nothing
 857 #endif