ghc/utils/hsc2hs/Main.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: Main.hs,v 1.9 2001/01/13 12:11: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, 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     "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 275     \    printf (\"{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d #-}\\n\", \
 276     \__GLASGOW_HASKELL__);\n\
 277     \#endif\n"++
 278     includeH++
 279     concatMap outSpecial toks
 280     where
 281     outSpecial (key, arg) = case key of
 282         "include" -> case inH of
 283             Nothing -> outOption ("-#include "++arg)
 284             Just _  -> ""
 285         "define" -> case inH of
 286             Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
 287             _ -> ""
 288         _ | conditional key -> "#"++key++" "++arg++"\n"
 289         _ -> ""
 290     goodForOptD arg = case arg of
 291         ""              -> True
 292         c:_ | isSpace c -> True
 293         '(':_           -> False
 294         _:s             -> goodForOptD s
 295     toOptD arg = case break isSpace arg of
 296         (name, "")      -> name
 297         (name, _:value) -> name++'=':dropWhile isSpace value
 298     includeH = concat [
 299         outOption ("-#include "++name++"")
 300         | name <- case inH of
 301             Nothing   -> [name | Include name <- flags]
 302             Just name -> ["\""++name++"\""]]
 303     outOption s = "    printf (\"{-# OPTIONS %s #-}\\n\", \""++
 304                   showCString s++"\");\n"
 305
 306 outTokenHs :: Token -> String
 307 outTokenHs (Text s) = "    fputs (\""++showCString s++"\", stdout);\n"
 308 outTokenHs (Special key arg) = case key of
 309     "include"           -> ""
 310     "define"            -> ""
 311     "undef"             -> ""
 312     "def"               -> ""
 313     _ | conditional key -> "#"++key++" "++arg++"\n"
 314     "let"               -> ""
 315     _                   -> "    hsc_"++key++" ("++arg++");\n"
 316
 317 outTokenH :: (String, String) -> String
 318 outTokenH (key, arg) = case key of
 319     "include" -> "#include "++arg++"\n"
 320     "define"  -> "#define " ++arg++"\n"
 321     "undef"   -> "#undef "  ++arg++"\n"
 322     "def"     -> case arg of
 323         's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 324         't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 325         'i':'n':'l':'i':'n':'e':' ':_ ->
 326             "#ifdef __GNUC__\n\
 327             \extern\n\
 328             \#endif\n"++
 329             arg++"\n"
 330         _ -> "extern "++header++";\n"
 331         where header = takeWhile (\c -> c/='{' && c/='=') arg
 332     _ | conditional key -> "#"++key++" "++arg++"\n"
 333     _ -> ""
 334
 335 outTokenC :: (String, String) -> String
 336 outTokenC (key, arg) = case key of
 337     "def" -> case arg of
 338         's':'t':'r':'u':'c':'t':' ':_ -> ""
 339         't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
 340         'i':'n':'l':'i':'n':'e':' ':_ ->
 341             "#ifndef __GNUC__\n\
 342             \extern\n\
 343             \#endif\n"++
 344             header++
 345             "\n#ifndef __GNUC__\n\
 346             \;\n\
 347             \#else\n"++
 348             body++
 349             "\n#endif\n"
 350         _ -> arg++"\n"
 351         where (header, body) = span (\c -> c/='{' && c/='=') arg
 352     _ | conditional key -> "#"++key++" "++arg++"\n"
 353     _ -> ""
 354
 355 conditional :: String -> Bool
 356 conditional "if"     = True
 357 conditional "ifdef"  = True
 358 conditional "ifndef" = True
 359 conditional "elif"   = True
 360 conditional "else"   = True
 361 conditional "endif"  = True
 362 conditional "error"  = True
 363 conditional _        = False
 364
 365 showCString :: String -> String
 366 showCString = concatMap showCChar
 367     where
 368     showCChar '\"' = "\\\""
 369     showCChar '\'' = "\\\'"
 370     showCChar '?'  = "\\?"
 371     showCChar '\\' = "\\\\"
 372     showCChar c | c >= ' ' && c <= '~' = [c]
 373     showCChar '\a' = "\\a"
 374     showCChar '\b' = "\\b"
 375     showCChar '\f' = "\\f"
 376     showCChar '\n' = "\\n\"\n           \""
 377     showCChar '\r' = "\\r"
 378     showCChar '\t' = "\\t"
 379     showCChar '\v' = "\\v"
 380     showCChar c    = ['\\',
 381                       intToDigit (ord c `quot` 64),
 382                       intToDigit (ord c `quot` 8 `mod` 8),
 383                       intToDigit (ord c          `mod` 8)]