ghc/utils/hsc2hs/Main.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: Main.hs,v 1.15 2001/02/05 18:01:39 rrt Exp $
   3 --
   4 -- (originally "GlueHsc.hs" by Marcin 'Qrczak' Kowalczyk)
   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 #include "../../includes/config.h"
  15
  16 import GetOpt
  17 import System      (getProgName, getArgs, ExitCode(..), system, exitWith, exitFailure)
  18 import Directory   (removeFile)
  19 import IO          (openFile, hClose, hPutStrLn, IOMode(..))
  20 import Parsec
  21 import ParsecError
  22 import Monad       (liftM, liftM2, when)
  23 import Char        (ord, intToDigit, isSpace, isAlpha, isAlphaNum, toUpper)
  24 import List        (intersperse)
  25 import Exception   (catchAllIO)
  26 #ifndef mingw32_TARGET_OS
  27 import Posix
  28 #endif
  29
  30 version :: String
  31 version = "hsc2hs-0.64"
  32
  33 data Flag
  34     = Help
  35     | Version
  36     | Template String
  37     | Compiler String
  38     | Linker   String
  39     | CompFlag String
  40     | LinkFlag String
  41     | Include  String
  42
  43 include :: String -> Flag
  44 include s@('\"':_) = Include s
  45 include s@('<' :_) = Include s
  46 include s          = Include ("\""++s++"\"")
  47
  48 options :: [OptDescr Flag]
  49 options = [
  50     Option "t" ["template"] (ReqArg Template   "FILE") "template file",
  51     Option ""  ["cc"]       (ReqArg Compiler   "PROG") "C compiler to use",
  52     Option ""  ["ld"]       (ReqArg Linker     "PROG") "linker to use",
  53     Option ""  ["cflag"]    (ReqArg CompFlag   "FLAG") "flag to pass to the C compiler",
  54     Option "I" []           (ReqArg (CompFlag . ("-I"++))
  55                                                "DIR")  "passed to the C compiler",
  56     Option ""  ["lflag"]    (ReqArg LinkFlag   "FLAG") "flag to pass to the linker",
  57     Option ""  ["include"]  (ReqArg include    "FILE") "as if placed in the source",
  58     Option ""  ["help"]     (NoArg  Help)              "display this help and exit",
  59     Option ""  ["version"]  (NoArg  Version)           "output version information and exit"]
  60
  61 main :: IO ()
  62 main = do
  63     prog <- getProgName
  64     let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]"
  65     args <- getArgs
  66     case getOpt Permute options args of
  67         (flags, _, _)
  68             | any isHelp    flags -> putStrLn (usageInfo header options)
  69             | any isVersion flags -> putStrLn version
  70             where
  71             isHelp    Help    = True; isHelp    _ = False
  72             isVersion Version = True; isVersion _ = False
  73         (_,     [],    [])   -> putStrLn (prog++": No input files")
  74         (flags, files, [])   -> mapM_ (processFile flags) files
  75         (_,     _,     errs) -> do
  76             mapM_ putStrLn errs
  77             putStrLn (usageInfo header options)
  78             exitFailure
  79
  80 processFile :: [Flag] -> String -> IO ()
  81 processFile flags name = do
  82     parsed <- parseFromFile parser name
  83     case parsed of
  84         Left err   -> do print err; exitFailure
  85         Right toks -> output flags name toks
  86
  87 data Token
  88     = Text    SourcePos String
  89     | Special SourcePos String String
  90
  91 parser :: Parser [Token]
  92 parser = many (text <|> special)
  93
  94 text :: Parser Token
  95 text = do
  96     pos <- getPosition
  97     liftM (Text pos . concat) $ many1
  98         (   many1 (satisfy (\ch -> not (isAlpha ch || ch `elem` "\"#'-_{")))
  99         <|> (do a <- satisfy (\ch -> isAlpha ch || ch == '_')
 100                 b <- many (satisfy (\ch -> isAlphaNum ch || ch == '_' || ch == '\''))
 101                 return (a:b))
 102         <|> (do char '\"'; a <- hsString '\"'; char '\"'; return ("\""++a++"\""))
 103         <|> (do try (string "##"); return "#")
 104         <|> (do char '\''; a <- hsString '\''; char '\''; return ("\'"++a++"\'"))
 105         <|> (do try (string "--"); a <- many (satisfy (/= '\n')); return ("--"++a))
 106         <|> string "-"
 107         <|> (do try (string "{-#"); optional (try linePragma); a <- hsComment; return ("{-#"++a))
 108         <|> (do try (string "{-"); a <- hsComment; return ("{-"++a))
 109         <|> string "{"
 110         <?> "Haskell source")
 111
 112 linePragma :: Parser ()
 113 linePragma = do
 114     state <- getState
 115     spaces
 116     string "LINE"
 117     skipMany1 space
 118     line <- many1 digit
 119     skipMany1 space
 120     char '\"'
 121     file <- many (satisfy (/= '\"'))
 122     char '\"'
 123     spaces
 124     string "#-}"
 125     setState state
 126     setPosition (newPos file (read line - 1) 1)
 127
 128 hsComment :: Parser String
 129 hsComment =
 130     (   (do a <- many1 (noneOf "-{"); b <- hsComment; return (a++b))
 131     <|> try (string "-}")
 132     <|> (do char '-'; b <- hsComment; return ('-':b))
 133     <|> (do try (string "{-"); a <- hsComment; b <- hsComment; return ("{-"++a++b))
 134     <|> (do char '{'; b <- hsComment; return ('{':b))
 135     <?> "Haskell comment")
 136
 137 hsString :: Char -> Parser String
 138 hsString quote =
 139     liftM concat $ many
 140     (   many1 (noneOf (quote:"\n\\"))
 141     <|> (do char '\\'; a <- escape; return ('\\':a))
 142     <?> "Haskell character or string")
 143     where
 144     escape = (do a <- many1 (satisfy isSpace); char '\\'; return (a++"\\"))
 145          <|> (do a <- anyChar; return [a])
 146
 147 special :: Parser Token
 148 special = do
 149     pos <- getPosition
 150     char '#'
 151     skipMany (oneOf " \t")
 152     key <- liftM2 (:) (letter <|> char '_') (many (alphaNum <|> char '_'))
 153         <?> "hsc directive"
 154     skipMany (oneOf " \t")
 155     arg <- argument pzero
 156     return (Special pos key arg)
 157
 158 argument :: Parser String -> Parser String
 159 argument eol =
 160     liftM concat $ many
 161     (   many1 (noneOf "\n\"\'()/[\\]{}")
 162     <|> eol
 163     <|> (do char '\"'; a <- cString '\"'; char '\"'; return ("\""++a++"\""))
 164     <|> (do char '\''; a <- cString '\''; char '\''; return ("\'"++a++"\'"))
 165     <|> (do char '('; a <- nested; char ')'; return ("("++a++")"))
 166     <|> (do try (string "/*"); cComment; return " ")
 167     <|> (do try (string "//"); skipMany (satisfy (/= '\n')); return " ")
 168     <|> string "/"
 169     <|> (do char '['; a <- nested; char ']'; return ("["++a++"]"))
 170     <|> (do char '\\'; a <- anyChar; return $ if a == '\n' then [] else ['\\',a])
 171     <|> (do char '{'; a <- nested; char '}'; return ("{"++a++"}"))
 172     <?> "C expression")
 173     where nested = argument (string "\n")
 174
 175 cComment :: Parser ()
 176 cComment =
 177     (   (do skipMany1 (noneOf "*"); cComment)
 178     <|> (do try (string "*/"); return ())
 179     <|> (do char '*'; cComment)
 180     <?> "C comment")
 181
 182 cString :: Char -> Parser String
 183 cString quote =
 184     liftM concat $ many
 185     (   many1 (noneOf (quote:"\n\\"))
 186     <|> (do char '\\'; a <- anyChar; return ['\\',a])
 187     <?> "C character or string")
 188
 189 output :: [Flag] -> String -> [Token] -> IO ()
 190 output flags name toks = let
 191     baseName = case reverse name of
 192         'c':base -> reverse base
 193         _        -> name++".hs"
 194     cProgName = baseName++"c_make_hs.c"
 195     oProgName = baseName++"c_make_hs.o"
 196     progName  = baseName++"c_make_hs"
 197     outHsName = baseName
 198     outHName  = baseName++".h"
 199     outCName  = baseName++".c"
 200
 201     execProgName = case progName of
 202         '/':_ -> progName
 203         _     -> "./"++progName
 204
 205     specials = [(pos, key, arg) | Special pos key arg <- toks]
 206
 207     needsC = any (\(_, key, _) -> key == "def") specials
 208     needsH = needsC
 209
 210     includeGuard = map fixChar outHName
 211         where
 212         fixChar c | isAlphaNum c = toUpper c
 213                   | otherwise    = '_'
 214
 215     in do
 216
 217     compiler <- case [c | Compiler c <- flags] of
 218         []  -> return "ghc"
 219         [c] -> return c
 220         _   -> onlyOne "compiler"
 221     linker <- case [l | Linker l <- flags] of
 222         []  -> return "gcc"
 223         [l] -> return l
 224         _   -> onlyOne "linker"
 225
 226     writeFile cProgName $
 227         concat ["#include \""++t++"\"\n" | Template t <- flags]++
 228         concat ["#include "++f++"\n"     | Include  f <- flags]++
 229         outHeaderCProg specials++
 230         "\nint main (void)\n{\n"++
 231         outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
 232         outHsLine (newPos name 0 1)++
 233         concatMap outTokenHs toks++
 234         "    return 0;\n}\n"
 235
 236     compilerStatus <- kludgedSystem $
 237         compiler++
 238         " -c"++
 239         concat [" "++f | CompFlag f <- flags]++
 240         " "++cProgName++
 241         " -o "++oProgName
 242     case compilerStatus of
 243         e@(ExitFailure _) -> exitWith e
 244         _                 -> return ()
 245     removeFile cProgName
 246
 247     linkerStatus <- kludgedSystem $
 248         linker++
 249         concat [" "++f | LinkFlag f <- flags]++
 250         " "++oProgName++
 251         " -o "++progName
 252     case linkerStatus of
 253         e@(ExitFailure _) -> exitWith e
 254         _                 -> return ()
 255     removeFile oProgName
 256
 257     kludgedSystem (execProgName++" >"++outHsName)
 258     removeFile progName
 259
 260     when needsH $ writeFile outHName $
 261         "#ifndef "++includeGuard++"\n\
 262         \#define "++includeGuard++"\n\
 263         \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 264         \#include <Rts.h>\n\
 265         \#endif\n\
 266         \#include <HsFFI.h>\n"++
 267         concat ["#include "++n++"\n" | Include n <- flags]++
 268         concatMap outTokenH specials++
 269         "#endif\n"
 270
 271     when needsC $ writeFile outCName $
 272         "#include \""++outHName++"\"\n"++
 273         concatMap outTokenC specials
 274
 275 onlyOne :: String -> IO a
 276 onlyOne what = do
 277     putStrLn ("Only one "++what++" may be specified")
 278     exitFailure
 279
 280 outHeaderCProg :: [(SourcePos, String, String)] -> String
 281 outHeaderCProg =
 282     concatMap $ \(pos, key, arg) -> case key of
 283         "include"           -> outCLine pos++"#include "++arg++"\n"
 284         "define"            -> outCLine pos++"#define "++arg++"\n"
 285         "undef"             -> outCLine pos++"#undef "++arg++"\n"
 286         "def"               -> case arg of
 287             's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
 288             't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
 289             _ -> ""
 290         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 291         "let"               -> case break (== '=') arg of
 292             (_,      "")     -> ""
 293             (header, _:body) -> case break isSpace header of
 294                 (name, args) ->
 295                     outCLine pos++
 296                     "#define hsc_"++name++"("++dropWhile isSpace args++") \
 297                     \printf ("++joinLines body++");\n"
 298         _ -> ""
 299     where
 300     joinLines = concat . intersperse " \\\n" . lines
 301
 302 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
 303 outHeaderHs flags inH toks =
 304     "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 305     \    printf (\"{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d #-}\\n\", \
 306     \__GLASGOW_HASKELL__);\n\
 307     \#endif\n"++
 308     includeH++
 309     concatMap outSpecial toks
 310     where
 311     outSpecial (pos, key, arg) = case key of
 312         "include" -> case inH of
 313             Nothing -> outOption ("-#include "++arg)
 314             Just _  -> ""
 315         "define" -> case inH of
 316             Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
 317             _ -> ""
 318         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 319         _ -> ""
 320     goodForOptD arg = case arg of
 321         ""              -> True
 322         c:_ | isSpace c -> True
 323         '(':_           -> False
 324         _:s             -> goodForOptD s
 325     toOptD arg = case break isSpace arg of
 326         (name, "")      -> name
 327         (name, _:value) -> name++'=':dropWhile isSpace value
 328     includeH = concat [
 329         outOption ("-#include "++name++"")
 330         | name <- case inH of
 331             Nothing   -> [name | Include name <- flags]
 332             Just name -> ["\""++name++"\""]]
 333     outOption s = "    printf (\"{-# OPTIONS %s #-}\\n\", \""++
 334                   showCString s++"\");\n"
 335
 336 outTokenHs :: Token -> String
 337 outTokenHs (Text pos text) =
 338     case break (== '\n') text of
 339         (all, [])       -> outText all
 340         (first, _:rest) ->
 341             outText (first++"\n")++
 342             outHsLine pos++
 343             outText rest
 344     where
 345     outText s = "    fputs (\""++showCString s++"\", stdout);\n"
 346 outTokenHs (Special pos key arg) =
 347     case key of
 348         "include"           -> ""
 349         "define"            -> ""
 350         "undef"             -> ""
 351         "def"               -> ""
 352         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 353         "let"               -> ""
 354         "enum"              -> outCLine pos++outEnum arg
 355         _                   -> outCLine pos++"    hsc_"++key++" ("++arg++");\n"
 356
 357 outEnum :: String -> String
 358 outEnum arg =
 359     case break (== ',') arg of
 360         (_, [])        -> ""
 361         (t, _:afterT) -> case break (== ',') afterT of
 362             (f, afterF) -> let
 363                 enums []    = ""
 364                 enums (_:s) = case break (== ',') s of
 365                     (enum, rest) -> let
 366                         this = case break (== '=') $ dropWhile isSpace enum of
 367                             (name, []) ->
 368                                 "    hsc_enum ("++t++", "++f++", \
 369                                 \hsc_haskellize (\""++name++"\"), "++
 370                                 name++");\n"
 371                             (hsName, _:cName) ->
 372                                 "    hsc_enum ("++t++", "++f++", \
 373                                 \printf (\"%s\", \""++hsName++"\"), "++
 374                                 cName++");\n"
 375                         in this++enums rest
 376                 in enums afterF
 377
 378 outTokenH :: (SourcePos, String, String) -> String
 379 outTokenH (pos, key, arg) =
 380     case key of
 381         "include" -> outCLine pos++"#include "++arg++"\n"
 382         "define"  -> outCLine pos++"#define " ++arg++"\n"
 383         "undef"   -> outCLine pos++"#undef "  ++arg++"\n"
 384         "def"     -> outCLine pos++case arg of
 385             's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 386             't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 387             'i':'n':'l':'i':'n':'e':' ':_ ->
 388                 "#ifdef __GNUC__\n\
 389                 \extern\n\
 390                 \#endif\n"++
 391                 arg++"\n"
 392             _ -> "extern "++header++";\n"
 393             where header = takeWhile (\c -> c /= '{' && c /= '=') arg
 394         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 395         _ -> ""
 396
 397 outTokenC :: (SourcePos, String, String) -> String
 398 outTokenC (pos, key, arg) =
 399     case key of
 400         "def" -> case arg of
 401             's':'t':'r':'u':'c':'t':' ':_ -> ""
 402             't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
 403             'i':'n':'l':'i':'n':'e':' ':_ ->
 404                 outCLine pos++
 405                 "#ifndef __GNUC__\n\
 406                 \extern\n\
 407                 \#endif\n"++
 408                 header++
 409                 "\n#ifndef __GNUC__\n\
 410                 \;\n\
 411                 \#else\n"++
 412                 body++
 413                 "\n#endif\n"
 414             _ -> outCLine pos++arg++"\n"
 415             where (header, body) = span (\c -> c /= '{' && c /= '=') arg
 416         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 417         _ -> ""
 418
 419 conditional :: String -> Bool
 420 conditional "if"      = True
 421 conditional "ifdef"   = True
 422 conditional "ifndef"  = True
 423 conditional "elif"    = True
 424 conditional "else"    = True
 425 conditional "endif"   = True
 426 conditional "error"   = True
 427 conditional "warning" = True
 428 conditional _         = False
 429
 430 sourceFileName :: SourcePos -> String
 431 sourceFileName pos = fileName (sourceName pos)
 432     where
 433     fileName s = case break (== '/') s of
 434         (name, [])      -> name
 435         (_,     _:rest) -> fileName rest
 436
 437 outCLine :: SourcePos -> String
 438 outCLine pos =
 439     "# "++show (sourceLine pos)++
 440     " \""++showCString (sourceFileName pos)++"\"\n"
 441
 442 outHsLine :: SourcePos -> String
 443 outHsLine pos =
 444     "    hsc_line ("++
 445     show (sourceLine pos + 1)++", \""++
 446     showCString (sourceFileName pos)++"\");\n"
 447
 448 showCString :: String -> String
 449 showCString = concatMap showCChar
 450     where
 451     showCChar '\"' = "\\\""
 452     showCChar '\'' = "\\\'"
 453     showCChar '?'  = "\\?"
 454     showCChar '\\' = "\\\\"
 455     showCChar c | c >= ' ' && c <= '~' = [c]
 456     showCChar '\a' = "\\a"
 457     showCChar '\b' = "\\b"
 458     showCChar '\f' = "\\f"
 459     showCChar '\n' = "\\n\"\n           \""
 460     showCChar '\r' = "\\r"
 461     showCChar '\t' = "\\t"
 462     showCChar '\v' = "\\v"
 463     showCChar c    = ['\\',
 464                       intToDigit (ord c `quot` 64),
 465                       intToDigit (ord c `quot` 8 `mod` 8),
 466                       intToDigit (ord c          `mod` 8)]
 467
 468 -- system that works feasibly under Windows (i.e. passes the command line to sh,
 469 -- because system() under Windows doesn't look at SHELL, and always uses CMD.EXE)
 470 kludgedSystem cmd
 471  = do
 472 #ifndef mingw32_TARGET_OS
 473    exit_code <- system cmd `catchAllIO`
 474                    (\_ -> exitFailure)
 475 #else
 476    pid <- myGetProcessID
 477    let tmp = "/tmp/sh" ++ show pid
 478    h <- openFile tmp WriteMode
 479    hPutStrLn h cmd
 480    hClose h
 481    exit_code <- system ("sh - " ++ tmp) `catchAllIO`
 482                    (\_ -> removeFile tmp >>
 483                           exitFailure)
 484    removeFile tmp
 485 #endif
 486    return exit_code
 487
 488 #ifdef mingw32_TARGET_OS
 489 foreign import "_getpid" myGetProcessID :: IO Int
 490 #else
 491 myGetProcessID :: IO Int
 492 myGetProcessID = Posix.getProcessID
 493 #endif