ghc/utils/hsc2hs/Main.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: Main.hs,v 1.6 2001/01/04 19:43:07 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 Monad     (liftM, liftM2, when)
  19 import Char      (ord, intToDigit, isSpace, isAlphaNum, toUpper)
  20 import List      (intersperse)
  21
  22 version :: String
  23 version = "0.64"
  24
  25 data Flag
  26     = Help
  27     | Version
  28     | Template String
  29     | Compiler String
  30     | Linker   String
  31     | CompFlag String
  32     | LinkFlag String
  33     | Include  String
  34
  35 include :: String -> Flag
  36 include s@('\"':_) = Include s
  37 include s@('<' :_) = Include s
  38 include s          = Include ("\""++s++"\"")
  39
  40 options :: [OptDescr Flag]
  41 options = [
  42     Option "t" ["template"] (ReqArg Template   "FILE") "template file",
  43     Option ""  ["cc"]       (ReqArg Compiler   "PROG") "C compiler to use",
  44     Option ""  ["ld"]       (ReqArg Linker     "PROG") "linker to use",
  45     Option ""  ["cflag"]    (ReqArg CompFlag   "FLAG") "flag to pass to the C compiler",
  46     Option "I" []           (ReqArg (CompFlag . ("-I"++))
  47                                                "DIR")  "passed to the C compiler",
  48     Option ""  ["lflag"]    (ReqArg LinkFlag   "FLAG") "flag to pass to the linker",
  49     Option ""  ["include"]  (ReqArg include    "FILE") "as if placed in the source",
  50     Option ""  ["help"]     (NoArg  Help)              "display this help and exit",
  51     Option ""  ["version"]  (NoArg  Version)           "output version information and exit"]
  52
  53 main :: IO ()
  54 main = do
  55     prog <- getProgName
  56     let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]"
  57     args <- getArgs
  58     case getOpt Permute options args of
  59         (flags, _, _)
  60             | any isHelp    flags -> putStrLn (usageInfo header options)
  61             | any isVersion flags -> putStrLn ("hsc2hs-"++version)
  62             where
  63             isHelp    Help    = True; isHelp    _ = False
  64             isVersion Version = True; isVersion _ = False
  65         (_,     [],    [])   -> putStrLn (prog++": No input files")
  66         (flags, files, [])   -> mapM_ (processFile flags) files
  67         (_,     _,     errs) -> do
  68             mapM_ putStrLn errs
  69             putStrLn (usageInfo header options)
  70             exitFailure
  71
  72 processFile :: [Flag] -> String -> IO ()
  73 processFile flags name = do
  74     parsed <- parseFromFile parser name
  75     case parsed of
  76         Left err -> print err >> exitFailure
  77         Right toks -> output flags name toks
  78
  79 data Token
  80     = Text String
  81     | Special String String
  82
  83 parser :: Parser [Token]
  84 parser = many (text <|> special)
  85
  86 text :: Parser Token
  87 text = liftM Text $ many1 $ satisfy (/= '#') <|> try (string "##" >> return '#')
  88
  89 special :: Parser Token
  90 special = do
  91     char '#'
  92     skipMany (oneOf " \t")
  93     key <- liftM2 (:) (letter <|> char '_') (many (alphaNum <|> char '_'))
  94         <?> "hsc directive"
  95     skipMany (oneOf " \t")
  96     arg <- argument pzero
  97     return (Special key arg)
  98
  99 argument :: Parser String -> Parser String
 100 argument eol = liftM concat $ many
 101     (   many1 (noneOf "\n\"\'()/[\\]{}")
 102     <|> eol
 103     <|> (do char '\"'; a <- cString '\''; char '\"'; return ("\""++a++"\""))
 104     <|> (do char '\''; a <- cString '\"'; char '\''; return ("\'"++a++"\'"))
 105     <|> (do char '('; a <- nested; char ')'; return ("("++a++")"))
 106     <|> (do try (string "/*"); comment; return " ")
 107     <|> (do try (string "//"); skipMany (satisfy (/= '\n')); return " ")
 108     <|> string "/"
 109     <|> (do char '['; a <- nested; char ']'; return ("["++a++"]"))
 110     <|> (do char '\\'; a <- anyChar; return ['\\',a])
 111     <|> (do char '{'; a <- nested; char '}'; return ("{"++a++"}"))
 112     <?> "C expression")
 113     where nested = argument (string "\n")
 114
 115 comment :: Parser ()
 116 comment = (do skipMany1 (noneOf "*"); comment)
 117       <|> (do try (string "*/"); return ())
 118       <|> (do char '*'; comment)
 119       <?> "C comment"
 120
 121 cString :: Char -> Parser String
 122 cString otherQuote = liftM concat $ many
 123     (   many1 (noneOf "\n\\\'\"")
 124     <|> string [otherQuote]
 125     <|> (do char '\\'; a <- anyChar; return ['\\',a])
 126     <?> "C character or string")
 127
 128 output :: [Flag] -> String -> [Token] -> IO ()
 129 output flags name toks = let
 130     baseName = case reverse name of
 131         'c':base -> reverse base
 132         _        -> name++".hs"
 133     cProgName = baseName++"c_make_hs.c"
 134     oProgName = baseName++"c_make_hs.o"
 135     progName  = baseName++"c_make_hs"
 136     outHsName = baseName
 137     outHName  = baseName++".h"
 138     outCName  = baseName++".c"
 139
 140     execProgName = case progName of
 141         '/':_ -> progName
 142         _     -> "./"++progName
 143
 144     specials = [(key, arg) | Special key arg <- toks]
 145
 146     needsC = any (\(key, _) -> key == "def") specials
 147     needsH = needsC
 148
 149     includeGuard = map fixChar outHName
 150         where
 151         fixChar c | isAlphaNum c = toUpper c
 152                   | otherwise    = '_'
 153
 154     in do
 155
 156     compiler <- case [c | Compiler c <- flags] of
 157         []  -> return "ghc"
 158         [c] -> return c
 159         _   -> onlyOne "compiler"
 160     linker <- case [l | Linker l <- flags] of
 161         []  -> return "gcc"
 162         [l] -> return l
 163         _   -> onlyOne "linker"
 164
 165     writeFile cProgName $
 166         concat ["#include \""++t++"\"\n" | Template t <- flags]++
 167         concat ["#include "++f++"\n"     | Include  f <- flags]++
 168         outHeaderCProg specials++
 169         "\nint main (void)\n{\n"++
 170         outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
 171         concatMap outTokenHs toks++
 172         "    return 0;\n}\n"
 173
 174     compilerStatus <- system $
 175         compiler++
 176         " -c"++
 177         concat [" "++f | CompFlag f <- flags]++
 178         " "++cProgName++
 179         " -o "++oProgName
 180     case compilerStatus of
 181         e@(ExitFailure _) -> exitWith e
 182         _                 -> return ()
 183     removeFile cProgName
 184
 185     linkerStatus <- system $
 186         linker++
 187         concat [" "++f | LinkFlag f <- flags]++
 188         " "++oProgName++
 189         " -o "++progName
 190     case linkerStatus of
 191         e@(ExitFailure _) -> exitWith e
 192         _                 -> return ()
 193     removeFile oProgName
 194
 195     system (execProgName++" >"++outHsName)
 196     removeFile progName
 197
 198     when needsH $ writeFile outHName $
 199         "#ifndef "++includeGuard++"\n\
 200         \#define "++includeGuard++"\n\
 201         \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 202         \#include <Rts.h>\n\
 203         \#endif\n\
 204         \#include <HsFFI.h>\n"++
 205         concat ["#include "++n++"\n" | Include n <- flags]++
 206         concatMap outTokenH specials++
 207         "#endif\n"
 208
 209     when needsC $ writeFile outCName $
 210         "#include \""++outHName++"\"\n"++
 211         concatMap outTokenC specials
 212
 213 onlyOne :: String -> IO a
 214 onlyOne what = do
 215     putStrLn ("Only one "++what++" may be specified")
 216     exitFailure
 217
 218 outHeaderCProg :: [(String, String)] -> String
 219 outHeaderCProg = concatMap $ \(key, arg) -> case key of
 220     "include"           -> "#include "++arg++"\n"
 221     "define"            -> "#define "++arg++"\n"
 222     "undef"             -> "#undef "++arg++"\n"
 223     "def"               -> case arg of
 224         's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 225         't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 226         _ -> ""
 227     _ | conditional key -> "#"++key++" "++arg++"\n"
 228     "let"               -> case break (== '=') arg of
 229         (_,      "")     -> ""
 230         (header, _:body) -> case break isSpace header of
 231             (name, args) ->
 232                 "#define hsc_"++name++"("++dropWhile isSpace args++") \
 233                 \printf ("++joinLines body++");\n"
 234     _ -> ""
 235     where
 236     joinLines = concat . intersperse " \\\n" . lines
 237
 238 outHeaderHs :: [Flag] -> Maybe String -> [(String, String)] -> String
 239 outHeaderHs flags inH toks =
 240     "    hsc_begin_options();\n"++
 241     includeH++
 242     concatMap outSpecial toks++
 243     "    hsc_end_options();\n\n"
 244     where
 245     outSpecial (key, arg) = case key of
 246         "include" -> case inH of
 247             Nothing -> outOption ("-#include "++arg)
 248             Just _  -> ""
 249         "define" -> case inH of
 250             Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
 251             _ -> ""
 252         "option" -> outOption arg
 253         _ | conditional key -> "#"++key++" "++arg++"\n"
 254         _ -> ""
 255     goodForOptD arg = case arg of
 256         ""              -> True
 257         c:_ | isSpace c -> True
 258         '(':_           -> False
 259         _:s             -> goodForOptD s
 260     toOptD arg = case break isSpace arg of
 261         (name, "")      -> name
 262         (name, _:value) -> name++'=':dropWhile isSpace value
 263     includeH = concat [
 264         outOption ("-#include "++name++"")
 265         | name <- case inH of
 266             Nothing   -> [name | Include name <- flags]
 267             Just name -> ["\""++name++"\""]]
 268     outOption s = "    hsc_option (\""++showCString s++"\");\n"
 269
 270 outTokenHs :: Token -> String
 271 outTokenHs (Text s) = "    fputs (\""++showCString s++"\", stdout);\n"
 272 outTokenHs (Special key arg) = case key of
 273     "include"           -> ""
 274     "define"            -> ""
 275     "undef"             -> ""
 276     "option"            -> ""
 277     "def"               -> ""
 278     _ | conditional key -> "#"++key++" "++arg++"\n"
 279     "let"               -> ""
 280     _                   -> "    hsc_"++key++" ("++arg++");\n"
 281
 282 outTokenH :: (String, String) -> String
 283 outTokenH (key, arg) = case key of
 284     "include" -> "#include "++arg++"\n"
 285     "define"  -> "#define " ++arg++"\n"
 286     "undef"   -> "#undef "  ++arg++"\n"
 287     "def"     -> case arg of
 288         's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 289         't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 290         'i':'n':'l':'i':'n':'e':' ':_ ->
 291             "#ifdef __GNUC__\n\
 292             \extern\n\
 293             \#endif\n"++
 294             arg++"\n"
 295         _ -> "extern "++header++";\n"
 296         where header = takeWhile (\c -> c/='{' && c/='=') arg
 297     _ | conditional key -> "#"++key++" "++arg++"\n"
 298     _ -> ""
 299
 300 outTokenC :: (String, String) -> String
 301 outTokenC (key, arg) = case key of
 302     "def" -> case arg of
 303         's':'t':'r':'u':'c':'t':' ':_ -> ""
 304         't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
 305         'i':'n':'l':'i':'n':'e':' ':_ ->
 306             "#ifndef __GNUC__\n\
 307             \extern\n\
 308             \#endif\n"++
 309             header++
 310             "\n#ifndef __GNUC__\n\
 311             \;\n\
 312             \#else\n"++
 313             body++
 314             "\n#endif\n"
 315         _ -> arg++"\n"
 316         where (header, body) = span (\c -> c/='{' && c/='=') arg
 317     _ | conditional key -> "#"++key++" "++arg++"\n"
 318     _ -> ""
 319
 320 conditional :: String -> Bool
 321 conditional "if"     = True
 322 conditional "ifdef"  = True
 323 conditional "ifndef" = True
 324 conditional "elif"   = True
 325 conditional "else"   = True
 326 conditional "endif"  = True
 327 conditional "error"  = True
 328 conditional _        = False
 329
 330 showCString :: String -> String
 331 showCString = concatMap showCChar
 332     where
 333     showCChar '\"' = "\\\""
 334     showCChar '\'' = "\\\'"
 335     showCChar '?'  = "\\?"
 336     showCChar '\\' = "\\\\"
 337     showCChar c | c >= ' ' && c <= '~' = [c]
 338     showCChar '\a' = "\\a"
 339     showCChar '\b' = "\\b"
 340     showCChar '\f' = "\\f"
 341     showCChar '\n' = "\\n\"\n           \""
 342     showCChar '\r' = "\\r"
 343     showCChar '\t' = "\\t"
 344     showCChar '\v' = "\\v"
 345     showCChar c    = ['\\',
 346                       intToDigit (ord c `quot` 64),
 347                       intToDigit (ord c `quot` 8 `mod` 8),
 348                       intToDigit (ord c          `mod` 8)]