ghc/utils/hsc2hs/Main.hs

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