ghc/utils/hsc2hs/Main.hs

   1 {-# OPTIONS -fffi #-}
   2
   3 ------------------------------------------------------------------------
   4 -- $Id: Main.hs,v 1.58 2004/06/29 17:14:01 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)
  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     -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code,
 567     -- so we use something slightly more complicated.   :-P
 568     when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $
 569        exitWith ExitSuccess
 570
 571
 572
 573     compilerStatus <- systemL beVerbose $
 574         compiler++
 575         " -c"++
 576         concat [" "++f | CompFlag f <- flags]++
 577         " "++cProgName++
 578         " -o "++oProgName
 579     case compilerStatus of
 580         e@(ExitFailure _) -> exitWith e
 581         _                 -> return ()
 582     removeFile cProgName
 583
 584     linkerStatus <- systemL beVerbose $
 585         linker++
 586         concat [" "++f | LinkFlag f <- flags]++
 587         " "++oProgName++
 588         " -o "++progName
 589     case linkerStatus of
 590         e@(ExitFailure _) -> exitWith e
 591         _                 -> return ()
 592     removeFile oProgName
 593
 594     progStatus <- systemL beVerbose (execProgName++" >"++outName)
 595     removeFile progName
 596     case progStatus of
 597         e@(ExitFailure _) -> exitWith e
 598         _                 -> return ()
 599
 600     when needsH $ writeFile outHName $
 601         "#ifndef "++includeGuard++"\n\
 602         \#define "++includeGuard++"\n\
 603         \#if " ++
 604         "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 605         \#include <Rts.h>\n\
 606         \#endif\n\
 607         \#include <HsFFI.h>\n\
 608         \#if __NHC__\n\
 609         \#undef HsChar\n\
 610         \#define HsChar int\n\
 611         \#endif\n"++
 612         concatMap outFlagH flags++
 613         concatMap outTokenH specials++
 614         "#endif\n"
 615
 616     when needsC $ writeFile outCName $
 617         "#include \""++outHFile++"\"\n"++
 618         concatMap outTokenC specials
 619         -- NB. outHFile not outHName; works better when processed
 620         -- by gcc or mkdependC.
 621
 622 systemL :: Bool -> String -> IO ExitCode
 623 systemL flg s = do
 624   when flg (hPutStrLn stderr ("Executing: " ++ s))
 625   system s
 626
 627 onlyOne :: String -> IO a
 628 onlyOne what = die ("Only one "++what++" may be specified\n")
 629
 630 outFlagHeaderCProg :: Flag -> String
 631 outFlagHeaderCProg (Template t)          = "#include \""++t++"\"\n"
 632 outFlagHeaderCProg (Include  f)          = "#include "++f++"\n"
 633 outFlagHeaderCProg (Define   n Nothing)  = "#define "++n++"\n"
 634 outFlagHeaderCProg (Define   n (Just v)) = "#define "++n++" "++v++"\n"
 635 outFlagHeaderCProg _                     = ""
 636
 637 outHeaderCProg :: (SourcePos, String, String) -> String
 638 outHeaderCProg (pos, key, arg) = case key of
 639     "include"           -> outCLine pos++"#include "++arg++"\n"
 640     "define"            -> outCLine pos++"#define "++arg++"\n"
 641     "undef"             -> outCLine pos++"#undef "++arg++"\n"
 642     "def"               -> case arg of
 643         's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
 644         't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
 645         _ -> ""
 646     _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 647     "let"               -> case break (== '=') arg of
 648         (_,      "")     -> ""
 649         (header, _:body) -> case break isSpace header of
 650             (name, args) ->
 651                 outCLine pos++
 652                 "#define hsc_"++name++"("++dropWhile isSpace args++") \
 653                 \printf ("++joinLines body++");\n"
 654     _ -> ""
 655    where
 656     joinLines = concat . intersperse " \\\n" . lines
 657
 658 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
 659 outHeaderHs flags inH toks =
 660     "#if " ++
 661     "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 662     \    printf (\"{-# OPTIONS -optc-D" ++
 663     "__GLASGOW_HASKELL__=%d #-}\\n\", \
 664     \__GLASGOW_HASKELL__);\n\
 665     \#endif\n"++
 666     case inH of
 667         Nothing -> concatMap outFlag flags++concatMap outSpecial toks
 668         Just f  -> outOption ("-#include \""++f++"\"")
 669     where
 670     outFlag (Include f)          = outOption ("-#include "++f)
 671     outFlag (Define  n Nothing)  = outOption ("-optc-D"++n)
 672     outFlag (Define  n (Just v)) = outOption ("-optc-D"++n++"="++v)
 673     outFlag _                    = ""
 674     outSpecial (pos, key, arg) = case key of
 675         "include"                  -> outOption ("-#include "++arg)
 676         "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
 677                  | otherwise       -> ""
 678         _ | conditional key        -> outCLine pos++"#"++key++" "++arg++"\n"
 679         _                          -> ""
 680     goodForOptD arg = case arg of
 681         ""              -> True
 682         c:_ | isSpace c -> True
 683         '(':_           -> False
 684         _:s             -> goodForOptD s
 685     toOptD arg = case break isSpace arg of
 686         (name, "")      -> name
 687         (name, _:value) -> name++'=':dropWhile isSpace value
 688     outOption s = "    printf (\"{-# OPTIONS %s #-}\\n\", \""++
 689                   showCString s++"\");\n"
 690
 691 outTokenHs :: Token -> String
 692 outTokenHs (Text pos txt) =
 693     case break (== '\n') txt of
 694         (allTxt, [])       -> outText allTxt
 695         (first, _:rest) ->
 696             outText (first++"\n")++
 697             outHsLine pos++
 698             outText rest
 699     where
 700     outText s = "    fputs (\""++showCString s++"\", stdout);\n"
 701 outTokenHs (Special pos key arg) =
 702     case key of
 703         "include"           -> ""
 704         "define"            -> ""
 705         "undef"             -> ""
 706         "def"               -> ""
 707         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 708         "let"               -> ""
 709         "enum"              -> outCLine pos++outEnum arg
 710         _                   -> outCLine pos++"    hsc_"++key++" ("++arg++");\n"
 711
 712 outEnum :: String -> String
 713 outEnum arg =
 714     case break (== ',') arg of
 715         (_, [])        -> ""
 716         (t, _:afterT) -> case break (== ',') afterT of
 717             (f, afterF) -> let
 718                 enums []    = ""
 719                 enums (_:s) = case break (== ',') s of
 720                     (enum, rest) -> let
 721                         this = case break (== '=') $ dropWhile isSpace enum of
 722                             (name, []) ->
 723                                 "    hsc_enum ("++t++", "++f++", \
 724                                 \hsc_haskellize (\""++name++"\"), "++
 725                                 name++");\n"
 726                             (hsName, _:cName) ->
 727                                 "    hsc_enum ("++t++", "++f++", \
 728                                 \printf (\"%s\", \""++hsName++"\"), "++
 729                                 cName++");\n"
 730                         in this++enums rest
 731                 in enums afterF
 732
 733 outFlagH :: Flag -> String
 734 outFlagH (Include  f)          = "#include "++f++"\n"
 735 outFlagH (Define   n Nothing)  = "#define "++n++"\n"
 736 outFlagH (Define   n (Just v)) = "#define "++n++" "++v++"\n"
 737 outFlagH _                     = ""
 738
 739 outTokenH :: (SourcePos, String, String) -> String
 740 outTokenH (pos, key, arg) =
 741     case key of
 742         "include" -> outCLine pos++"#include "++arg++"\n"
 743         "define"  -> outCLine pos++"#define " ++arg++"\n"
 744         "undef"   -> outCLine pos++"#undef "  ++arg++"\n"
 745         "def"     -> outCLine pos++case arg of
 746             's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 747             't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 748             'i':'n':'l':'i':'n':'e':' ':_ ->
 749                 "#ifdef __GNUC__\n\
 750                 \extern\n\
 751                 \#endif\n"++
 752                 arg++"\n"
 753             _ -> "extern "++header++";\n"
 754           where header = takeWhile (\c -> c /= '{' && c /= '=') arg
 755         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 756         _ -> ""
 757
 758 outTokenC :: (SourcePos, String, String) -> String
 759 outTokenC (pos, key, arg) =
 760     case key of
 761         "def" -> case arg of
 762             's':'t':'r':'u':'c':'t':' ':_ -> ""
 763             't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
 764             'i':'n':'l':'i':'n':'e':' ':arg' ->
 765                 case span (\c -> c /= '{' && c /= '=') arg' of
 766                 (header, body) ->
 767                     outCLine pos++
 768                     "#ifndef __GNUC__\n\
 769                     \extern inline\n\
 770                     \#endif\n"++
 771                     header++
 772                     "\n#ifndef __GNUC__\n\
 773                     \;\n\
 774                     \#else\n"++
 775                     body++
 776                     "\n#endif\n"
 777             _ -> outCLine pos++arg++"\n"
 778         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 779         _ -> ""
 780
 781 conditional :: String -> Bool
 782 conditional "if"      = True
 783 conditional "ifdef"   = True
 784 conditional "ifndef"  = True
 785 conditional "elif"    = True
 786 conditional "else"    = True
 787 conditional "endif"   = True
 788 conditional "error"   = True
 789 conditional "warning" = True
 790 conditional _         = False
 791
 792 outCLine :: SourcePos -> String
 793 outCLine (SourcePos name line) =
 794     "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n"
 795
 796 outHsLine :: SourcePos -> String
 797 outHsLine (SourcePos name line) =
 798     "    hsc_line ("++show (line + 1)++", \""++
 799     showCString (snd (splitName name))++"\");\n"
 800
 801 showCString :: String -> String
 802 showCString = concatMap showCChar
 803     where
 804     showCChar '\"' = "\\\""
 805     showCChar '\'' = "\\\'"
 806     showCChar '?'  = "\\?"
 807     showCChar '\\' = "\\\\"
 808     showCChar c | c >= ' ' && c <= '~' = [c]
 809     showCChar '\a' = "\\a"
 810     showCChar '\b' = "\\b"
 811     showCChar '\f' = "\\f"
 812     showCChar '\n' = "\\n\"\n           \""
 813     showCChar '\r' = "\\r"
 814     showCChar '\t' = "\\t"
 815     showCChar '\v' = "\\v"
 816     showCChar c    = ['\\',
 817                       intToDigit (ord c `quot` 64),
 818                       intToDigit (ord c `quot` 8 `mod` 8),
 819                       intToDigit (ord c          `mod` 8)]
 820
 821
 822
 823 -----------------------------------------
 824 --      Cut and pasted from ghc/compiler/SysTools
 825 -- Convert paths foo/baz to foo\baz on Windows
 826
 827 dosifyPath :: String -> String
 828 #if defined(mingw32_HOST_OS)
 829 dosifyPath xs = subst '/' '\\' xs
 830
 831 unDosifyPath :: String -> String
 832 unDosifyPath xs = subst '\\' '/' xs
 833
 834 subst :: Eq a => a -> a -> [a] -> [a]
 835 subst a b ls = map (\ x -> if x == a then b else x) ls
 836
 837 getExecDir :: String -> IO (Maybe String)
 838 -- (getExecDir cmd) returns the directory in which the current
 839 --                  executable, which should be called 'cmd', is running
 840 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
 841 -- you'll get "/a/b/c" back as the result
 842 getExecDir cmd
 843   = allocaArray len $ \buf -> do
 844         ret <- getModuleFileName nullPtr buf len
 845         if ret == 0 then return Nothing
 846                     else do s <- peekCString buf
 847                             return (Just (reverse (drop (length cmd)
 848                                                         (reverse (unDosifyPath s)))))
 849   where
 850     len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
 851
 852 foreign import stdcall unsafe "GetModuleFileNameA"
 853   getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
 854
 855 #else
 856 dosifyPath xs = xs
 857
 858 getExecDir :: String -> IO (Maybe String)
 859 getExecDir _ = return Nothing
 860 #endif