ghc/utils/hsc2hs/Main.hs

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