ghc/utils/hsc2hs/Main.hs

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