ghc/utils/hsc2hs/Main.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: Main.hs,v 1.8 2001/01/12 22:54:23 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, isAlpha, isAlphaNum, toUpper)
  20 import List      (intersperse)
  21
  22 version :: String
  23 version = "hsc2hs-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 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   -> do 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 =
  88     liftM (Text . concat) $ many1
  89     (   many1 (satisfy (\ch -> not (isAlpha ch || ch `elem` "\"#'-_{")))
  90     <|> (do a <- satisfy (\ch -> isAlpha ch || ch == '_')
  91             b <- many (satisfy (\ch -> isAlphaNum ch || ch == '_' || ch == '\''))
  92             return (a:b))
  93     <|> (do char '\"'; a <- hsString '\"'; char '\"'; return ("\""++a++"\""))
  94     <|> (do try (string "##"); return "#")
  95     <|> (do char '\''; a <- hsString '\''; char '\''; return ("\'"++a++"\'"))
  96     <|> (do try (string "--"); a <- many (satisfy (/= '\n')); return ("--"++a))
  97     <|> string "-"
  98     <|> (do try (string "{-"); a <- hsComment; return ("{-"++a))
  99     <|> string "{"
 100     <?> "Haskell source")
 101
 102 hsComment :: Parser String
 103 hsComment =
 104     (   (do a <- many1 (noneOf "-{"); b <- hsComment; return (a++b))
 105     <|> try (string "-}")
 106     <|> (do char '-'; b <- hsComment; return ('-':b))
 107     <|> (do try (string "{-"); a <- hsComment; b <- hsComment; return ("{-"++a++b))
 108     <|> (do char '{'; b <- hsComment; return ('{':b))
 109     <?> "Haskell comment")
 110
 111 hsString :: Char -> Parser String
 112 hsString quote =
 113     liftM concat $ many
 114     (   many1 (noneOf (quote:"\n\\"))
 115     <|> (do char '\\'; a <- escape; return ('\\':a))
 116     <?> "Haskell character or string")
 117     where
 118     escape = (do a <- many1 (satisfy isSpace); char '\\'; return (a++"\\"))
 119          <|> (do a <- anyChar; return [a])
 120
 121 special :: Parser Token
 122 special = do
 123     char '#'
 124     skipMany (oneOf " \t")
 125     key <- liftM2 (:) (letter <|> char '_') (many (alphaNum <|> char '_'))
 126         <?> "hsc directive"
 127     skipMany (oneOf " \t")
 128     arg <- argument pzero
 129     return (Special key arg)
 130
 131 argument :: Parser String -> Parser String
 132 argument eol =
 133     liftM concat $ many
 134     (   many1 (noneOf "\n\"\'()/[\\]{}")
 135     <|> eol
 136     <|> (do char '\"'; a <- cString '\"'; char '\"'; return ("\""++a++"\""))
 137     <|> (do char '\''; a <- cString '\''; char '\''; return ("\'"++a++"\'"))
 138     <|> (do char '('; a <- nested; char ')'; return ("("++a++")"))
 139     <|> (do try (string "/*"); cComment; return " ")
 140     <|> (do try (string "//"); skipMany (satisfy (/= '\n')); return " ")
 141     <|> string "/"
 142     <|> (do char '['; a <- nested; char ']'; return ("["++a++"]"))
 143     <|> (do char '\\'; a <- anyChar; return $ if a == '\n' then [] else ['\\',a])
 144     <|> (do char '{'; a <- nested; char '}'; return ("{"++a++"}"))
 145     <?> "C expression")
 146     where nested = argument (string "\n")
 147
 148 cComment :: Parser ()
 149 cComment =
 150     (   (do skipMany1 (noneOf "*"); cComment)
 151     <|> (do try (string "*/"); return ())
 152     <|> (do char '*'; cComment)
 153     <?> "C comment")
 154
 155 cString :: Char -> Parser String
 156 cString quote =
 157     liftM concat $ many
 158     (   many1 (noneOf (quote:"\n\\"))
 159     <|> (do char '\\'; a <- anyChar; return ['\\',a])
 160     <?> "C character or string")
 161
 162 output :: [Flag] -> String -> [Token] -> IO ()
 163 output flags name toks = let
 164     baseName = case reverse name of
 165         'c':base -> reverse base
 166         _        -> name++".hs"
 167     cProgName = baseName++"c_make_hs.c"
 168     oProgName = baseName++"c_make_hs.o"
 169     progName  = baseName++"c_make_hs"
 170     outHsName = baseName
 171     outHName  = baseName++".h"
 172     outCName  = baseName++".c"
 173
 174     execProgName = case progName of
 175         '/':_ -> progName
 176         _     -> "./"++progName
 177
 178     specials = [(key, arg) | Special key arg <- toks]
 179
 180     needsC = any (\(key, _) -> key == "def") specials
 181     needsH = needsC
 182
 183     includeGuard = map fixChar outHName
 184         where
 185         fixChar c | isAlphaNum c = toUpper c
 186                   | otherwise    = '_'
 187
 188     in do
 189
 190     compiler <- case [c | Compiler c <- flags] of
 191         []  -> return "ghc"
 192         [c] -> return c
 193         _   -> onlyOne "compiler"
 194     linker <- case [l | Linker l <- flags] of
 195         []  -> return "gcc"
 196         [l] -> return l
 197         _   -> onlyOne "linker"
 198
 199     writeFile cProgName $
 200         concat ["#include \""++t++"\"\n" | Template t <- flags]++
 201         concat ["#include "++f++"\n"     | Include  f <- flags]++
 202         outHeaderCProg specials++
 203         "\nint main (void)\n{\n"++
 204         outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
 205         concatMap outTokenHs toks++
 206         "    return 0;\n}\n"
 207
 208     compilerStatus <- system $
 209         compiler++
 210         " -c"++
 211         concat [" "++f | CompFlag f <- flags]++
 212         " "++cProgName++
 213         " -o "++oProgName
 214     case compilerStatus of
 215         e@(ExitFailure _) -> exitWith e
 216         _                 -> return ()
 217     removeFile cProgName
 218
 219     linkerStatus <- system $
 220         linker++
 221         concat [" "++f | LinkFlag f <- flags]++
 222         " "++oProgName++
 223         " -o "++progName
 224     case linkerStatus of
 225         e@(ExitFailure _) -> exitWith e
 226         _                 -> return ()
 227     removeFile oProgName
 228
 229     system (execProgName++" >"++outHsName)
 230     removeFile progName
 231
 232     when needsH $ writeFile outHName $
 233         "#ifndef "++includeGuard++"\n\
 234         \#define "++includeGuard++"\n\
 235         \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 236         \#include <Rts.h>\n\
 237         \#endif\n\
 238         \#include <HsFFI.h>\n"++
 239         concat ["#include "++n++"\n" | Include n <- flags]++
 240         concatMap outTokenH specials++
 241         "#endif\n"
 242
 243     when needsC $ writeFile outCName $
 244         "#include \""++outHName++"\"\n"++
 245         concatMap outTokenC specials
 246
 247 onlyOne :: String -> IO a
 248 onlyOne what = do
 249     putStrLn ("Only one "++what++" may be specified")
 250     exitFailure
 251
 252 outHeaderCProg :: [(String, String)] -> String
 253 outHeaderCProg = concatMap $ \(key, arg) -> case key of
 254     "include"           -> "#include "++arg++"\n"
 255     "define"            -> "#define "++arg++"\n"
 256     "undef"             -> "#undef "++arg++"\n"
 257     "def"               -> case arg of
 258         's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 259         't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 260         _ -> ""
 261     _ | conditional key -> "#"++key++" "++arg++"\n"
 262     "let"               -> case break (== '=') arg of
 263         (_,      "")     -> ""
 264         (header, _:body) -> case break isSpace header of
 265             (name, args) ->
 266                 "#define hsc_"++name++"("++dropWhile isSpace args++") \
 267                 \printf ("++joinLines body++");\n"
 268     _ -> ""
 269     where
 270     joinLines = concat . intersperse " \\\n" . lines
 271
 272 outHeaderHs :: [Flag] -> Maybe String -> [(String, String)] -> String
 273 outHeaderHs flags inH toks =
 274     "    hsc_begin_options();\n"++
 275     includeH++
 276     concatMap outSpecial toks++
 277     "    hsc_end_options();\n\n"
 278     where
 279     outSpecial (key, arg) = case key of
 280         "include" -> case inH of
 281             Nothing -> outOption ("-#include "++arg)
 282             Just _  -> ""
 283         "define" -> case inH of
 284             Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
 285             _ -> ""
 286         "option" -> outOption arg
 287         _ | conditional key -> "#"++key++" "++arg++"\n"
 288         _ -> ""
 289     goodForOptD arg = case arg of
 290         ""              -> True
 291         c:_ | isSpace c -> True
 292         '(':_           -> False
 293         _:s             -> goodForOptD s
 294     toOptD arg = case break isSpace arg of
 295         (name, "")      -> name
 296         (name, _:value) -> name++'=':dropWhile isSpace value
 297     includeH = concat [
 298         outOption ("-#include "++name++"")
 299         | name <- case inH of
 300             Nothing   -> [name | Include name <- flags]
 301             Just name -> ["\""++name++"\""]]
 302     outOption s = "    hsc_option (\""++showCString s++"\");\n"
 303
 304 outTokenHs :: Token -> String
 305 outTokenHs (Text s) = "    fputs (\""++showCString s++"\", stdout);\n"
 306 outTokenHs (Special key arg) = case key of
 307     "include"           -> ""
 308     "define"            -> ""
 309     "undef"             -> ""
 310     "option"            -> ""
 311     "def"               -> ""
 312     _ | conditional key -> "#"++key++" "++arg++"\n"
 313     "let"               -> ""
 314     _                   -> "    hsc_"++key++" ("++arg++");\n"
 315
 316 outTokenH :: (String, String) -> String
 317 outTokenH (key, arg) = case key of
 318     "include" -> "#include "++arg++"\n"
 319     "define"  -> "#define " ++arg++"\n"
 320     "undef"   -> "#undef "  ++arg++"\n"
 321     "def"     -> case arg of
 322         's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 323         't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 324         'i':'n':'l':'i':'n':'e':' ':_ ->
 325             "#ifdef __GNUC__\n\
 326             \extern\n\
 327             \#endif\n"++
 328             arg++"\n"
 329         _ -> "extern "++header++";\n"
 330         where header = takeWhile (\c -> c/='{' && c/='=') arg
 331     _ | conditional key -> "#"++key++" "++arg++"\n"
 332     _ -> ""
 333
 334 outTokenC :: (String, String) -> String
 335 outTokenC (key, arg) = case key of
 336     "def" -> case arg of
 337         's':'t':'r':'u':'c':'t':' ':_ -> ""
 338         't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
 339         'i':'n':'l':'i':'n':'e':' ':_ ->
 340             "#ifndef __GNUC__\n\
 341             \extern\n\
 342             \#endif\n"++
 343             header++
 344             "\n#ifndef __GNUC__\n\
 345             \;\n\
 346             \#else\n"++
 347             body++
 348             "\n#endif\n"
 349         _ -> arg++"\n"
 350         where (header, body) = span (\c -> c/='{' && c/='=') arg
 351     _ | conditional key -> "#"++key++" "++arg++"\n"
 352     _ -> ""
 353
 354 conditional :: String -> Bool
 355 conditional "if"     = True
 356 conditional "ifdef"  = True
 357 conditional "ifndef" = True
 358 conditional "elif"   = True
 359 conditional "else"   = True
 360 conditional "endif"  = True
 361 conditional "error"  = True
 362 conditional _        = False
 363
 364 showCString :: String -> String
 365 showCString = concatMap showCChar
 366     where
 367     showCChar '\"' = "\\\""
 368     showCChar '\'' = "\\\'"
 369     showCChar '?'  = "\\?"
 370     showCChar '\\' = "\\\\"
 371     showCChar c | c >= ' ' && c <= '~' = [c]
 372     showCChar '\a' = "\\a"
 373     showCChar '\b' = "\\b"
 374     showCChar '\f' = "\\f"
 375     showCChar '\n' = "\\n\"\n           \""
 376     showCChar '\r' = "\\r"
 377     showCChar '\t' = "\\t"
 378     showCChar '\v' = "\\v"
 379     showCChar c    = ['\\',
 380                       intToDigit (ord c `quot` 64),
 381                       intToDigit (ord c `quot` 8 `mod` 8),
 382                       intToDigit (ord c          `mod` 8)]