ghc/utils/hsc2hs/Main.hs

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