ghc/utils/hsc2hs/Main.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: Main.hs,v 1.21 2001/02/13 17:40:37 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(..), exitWith, exitFailure)
  16 import KludgedSystem (system, defaultCompiler)
  17 import Directory     (removeFile)
  18 import Parsec
  19 import ParsecError
  20 import Monad         (liftM, liftM2, when)
  21 import Char          (ord, intToDigit, isSpace, isAlpha, isAlphaNum, toUpper)
  22 import List          (intersperse)
  23
  24 version :: String
  25 version = "hsc2hs-0.64"
  26
  27 data Flag
  28     = Help
  29     | Version
  30     | Template String
  31     | Compiler String
  32     | Linker   String
  33     | CompFlag String
  34     | LinkFlag String
  35     | Include  String
  36
  37 include :: String -> Flag
  38 include s@('\"':_) = Include s
  39 include s@('<' :_) = Include s
  40 include s          = Include ("\""++s++"\"")
  41
  42 options :: [OptDescr Flag]
  43 options = [
  44     Option "t" ["template"] (ReqArg Template   "FILE") "template file",
  45     Option ""  ["cc"]       (ReqArg Compiler   "PROG") "C compiler to use",
  46     Option ""  ["ld"]       (ReqArg Linker     "PROG") "linker to use",
  47     Option ""  ["cflag"]    (ReqArg CompFlag   "FLAG") "flag to pass to the C compiler",
  48     Option "I" []           (ReqArg (CompFlag . ("-I"++))
  49                                                "DIR")  "passed to the C compiler",
  50     Option ""  ["lflag"]    (ReqArg LinkFlag   "FLAG") "flag to pass to the linker",
  51     Option ""  ["include"]  (ReqArg include    "FILE") "as if placed in the source",
  52     Option ""  ["help"]     (NoArg  Help)              "display this help and exit",
  53     Option ""  ["version"]  (NoArg  Version)           "output version information and exit"]
  54
  55 main :: IO ()
  56 main = do
  57     prog <- getProgName
  58     let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]"
  59     args <- getArgs
  60     case getOpt Permute options args of
  61         (flags, _, _)
  62             | any isHelp    flags -> putStrLn (usageInfo header options)
  63             | any isVersion flags -> putStrLn version
  64             where
  65             isHelp    Help    = True; isHelp    _ = False
  66             isVersion Version = True; isVersion _ = False
  67         (_,     [],    [])   -> putStrLn (prog++": No input files")
  68         (flags, files, [])   -> mapM_ (processFile flags) files
  69         (_,     _,     errs) -> do
  70             mapM_ putStrLn errs
  71             putStrLn (usageInfo header options)
  72             exitFailure
  73
  74 processFile :: [Flag] -> String -> IO ()
  75 processFile flags name = do
  76     parsed <- parseFromFile parser name
  77     case parsed of
  78         Left err   -> do print err; exitFailure
  79         Right toks -> output flags name toks
  80
  81 data Token
  82     = Text    SourcePos String
  83     | Special SourcePos String String
  84
  85 parser :: Parser [Token]
  86 parser = many (text <|> special)
  87
  88 text :: Parser Token
  89 text = do
  90     pos <- getPosition
  91     liftM (Text pos . concat) $ many1
  92         (   many1 (satisfy (\ch -> not (isAlpha ch || ch `elem` "\"#'-_{")))
  93         <|> (do a <- satisfy (\ch -> isAlpha ch || ch == '_')
  94                 b <- many (satisfy (\ch -> isAlphaNum ch || ch == '_' || ch == '\''))
  95                 return (a:b))
  96         <|> (do char '\"'; a <- hsString '\"'; char '\"'; return ("\""++a++"\""))
  97         <|> (do try (string "##"); return "#")
  98         <|> (do char '\''; a <- hsString '\''; char '\''; return ("\'"++a++"\'"))
  99         <|> (do try (string "--"); a <- many (satisfy (/= '\n')); return ("--"++a))
 100         <|> string "-"
 101         <|> (do try (string "{-#"); optional (try linePragma); a <- hsComment; return ("{-#"++a))
 102         <|> (do try (string "{-"); a <- hsComment; return ("{-"++a))
 103         <|> string "{"
 104         <?> "Haskell source")
 105
 106 linePragma :: Parser ()
 107 linePragma = do
 108     state <- getState
 109     spaces
 110     string "LINE"
 111     skipMany1 space
 112     line <- many1 digit
 113     skipMany1 space
 114     char '\"'
 115     file <- many (satisfy (/= '\"'))
 116     char '\"'
 117     spaces
 118     string "#-}"
 119     setState state
 120     setPosition (newPos file (read line - 1) 1)
 121
 122 hsComment :: Parser String
 123 hsComment =
 124     (   (do a <- many1 (noneOf "-{"); b <- hsComment; return (a++b))
 125     <|> try (string "-}")
 126     <|> (do char '-'; b <- hsComment; return ('-':b))
 127     <|> (do try (string "{-"); a <- hsComment; b <- hsComment; return ("{-"++a++b))
 128     <|> (do char '{'; b <- hsComment; return ('{':b))
 129     <?> "Haskell comment")
 130
 131 hsString :: Char -> Parser String
 132 hsString quote =
 133     liftM concat $ many
 134     (   many1 (noneOf (quote:"\n\\"))
 135     <|> (do char '\\'; a <- escape; return ('\\':a))
 136     <?> "Haskell character or string")
 137     where
 138     escape = (do a <- many1 (satisfy isSpace); char '\\'; return (a++"\\"))
 139          <|> (do a <- anyChar; return [a])
 140
 141 special :: Parser Token
 142 special = do
 143     pos <- getPosition
 144     char '#'
 145     skipMany (oneOf " \t")
 146     key <- liftM2 (:) (letter <|> char '_') (many (alphaNum <|> char '_'))
 147         <?> "hsc directive"
 148     skipMany (oneOf " \t")
 149     arg <- argument pzero
 150     return (Special pos key arg)
 151
 152 argument :: Parser String -> Parser String
 153 argument eol =
 154     liftM concat $ many
 155     (   many1 (noneOf "\n\"\'()/[\\]{}")
 156     <|> eol
 157     <|> (do char '\"'; a <- cString '\"'; char '\"'; return ("\""++a++"\""))
 158     <|> (do char '\''; a <- cString '\''; char '\''; return ("\'"++a++"\'"))
 159     <|> (do char '('; a <- nested; char ')'; return ("("++a++")"))
 160     <|> (do try (string "/*"); cComment; return " ")
 161     <|> (do try (string "//"); skipMany (satisfy (/= '\n')); return " ")
 162     <|> string "/"
 163     <|> (do char '['; a <- nested; char ']'; return ("["++a++"]"))
 164     <|> (do char '\\'; a <- anyChar; return $ if a == '\n' then [] else ['\\',a])
 165     <|> (do char '{'; a <- nested; char '}'; return ("{"++a++"}"))
 166     <?> "C expression")
 167     where nested = argument (string "\n")
 168
 169 cComment :: Parser ()
 170 cComment =
 171     (   (do skipMany1 (noneOf "*"); cComment)
 172     <|> (do try (string "*/"); return ())
 173     <|> (do char '*'; cComment)
 174     <?> "C comment")
 175
 176 cString :: Char -> Parser String
 177 cString quote =
 178     liftM concat $ many
 179     (   many1 (noneOf (quote:"\n\\"))
 180     <|> (do char '\\'; a <- anyChar; return ['\\',a])
 181     <?> "C character or string")
 182
 183 output :: [Flag] -> String -> [Token] -> IO ()
 184 output flags name toks = let
 185     baseName = case reverse name of
 186         'c':base -> reverse base
 187         _        -> name++".hs"
 188     cProgName = baseName++"c_make_hs.c"
 189     oProgName = baseName++"c_make_hs.o"
 190     progName  = baseName++"c_make_hs"
 191     outHsName = baseName
 192     outHName  = baseName++".h"
 193     outCName  = baseName++".c"
 194
 195     execProgName = case progName of
 196         '/':_ -> progName
 197         _     -> "./"++progName
 198
 199     specials = [(pos, key, arg) | Special pos key arg <- toks]
 200
 201     needsC = any (\(_, key, _) -> key == "def") specials
 202     needsH = needsC
 203
 204     includeGuard = map fixChar outHName
 205         where
 206         fixChar c | isAlphaNum c = toUpper c
 207                   | otherwise    = '_'
 208
 209     in do
 210
 211     compiler <- case [c | Compiler c <- flags] of
 212         []  -> return "ghc"
 213         [c] -> return c
 214         _   -> onlyOne "compiler"
 215     linker <- case [l | Linker l <- flags] of
 216         []  -> return defaultCompiler
 217         [l] -> return l
 218         _   -> onlyOne "linker"
 219
 220     writeFile cProgName $
 221         concat ["#include \""++t++"\"\n" | Template t <- flags]++
 222         concat ["#include "++f++"\n"     | Include  f <- flags]++
 223         outHeaderCProg specials++
 224         "\nint main (void)\n{\n"++
 225         outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
 226         outHsLine (newPos name 0 1)++
 227         concatMap outTokenHs toks++
 228         "    return 0;\n}\n"
 229
 230     compilerStatus <- system $
 231         compiler++
 232         " -c"++
 233         concat [" "++f | CompFlag f <- flags]++
 234         " "++cProgName++
 235         " -o "++oProgName
 236     case compilerStatus of
 237         e@(ExitFailure _) -> exitWith e
 238         _                 -> return ()
 239     removeFile cProgName
 240
 241     linkerStatus <- system $
 242         linker++
 243         concat [" "++f | LinkFlag f <- flags]++
 244         " "++oProgName++
 245         " -o "++progName
 246     case linkerStatus of
 247         e@(ExitFailure _) -> exitWith e
 248         _                 -> return ()
 249     removeFile oProgName
 250
 251     system (execProgName++" >"++outHsName)
 252     removeFile progName
 253
 254     when needsH $ writeFile outHName $
 255         "#ifndef "++includeGuard++"\n\
 256         \#define "++includeGuard++"\n\
 257         \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 258         \#include <Rts.h>\n\
 259         \#endif\n\
 260         \#include <HsFFI.h>\n\
 261         \#if __NHC__\n\
 262         \#undef HsChar\n\
 263         \#define HsChar int\n\
 264         \#endif\n"++
 265         concat ["#include "++n++"\n" | Include n <- flags]++
 266         concatMap outTokenH specials++
 267         "#endif\n"
 268
 269     when needsC $ writeFile outCName $
 270         "#include \""++outHName++"\"\n"++
 271         concatMap outTokenC specials
 272
 273 onlyOne :: String -> IO a
 274 onlyOne what = do
 275     putStrLn ("Only one "++what++" may be specified")
 276     exitFailure
 277
 278 outHeaderCProg :: [(SourcePos, String, String)] -> String
 279 outHeaderCProg =
 280     concatMap $ \(pos, key, arg) -> case key of
 281         "include"           -> outCLine pos++"#include "++arg++"\n"
 282         "define"            -> outCLine pos++"#define "++arg++"\n"
 283         "undef"             -> outCLine pos++"#undef "++arg++"\n"
 284         "def"               -> case arg of
 285             's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
 286             't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
 287             _ -> ""
 288         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 289         "let"               -> case break (== '=') arg of
 290             (_,      "")     -> ""
 291             (header, _:body) -> case break isSpace header of
 292                 (name, args) ->
 293                     outCLine pos++
 294                     "#define hsc_"++name++"("++dropWhile isSpace args++") \
 295                     \printf ("++joinLines body++");\n"
 296         _ -> ""
 297     where
 298     joinLines = concat . intersperse " \\\n" . lines
 299
 300 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
 301 outHeaderHs flags inH toks =
 302     "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 303     \    printf (\"{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d #-}\\n\", \
 304     \__GLASGOW_HASKELL__);\n\
 305     \#endif\n"++
 306     includeH++
 307     concatMap outSpecial toks
 308     where
 309     outSpecial (pos, key, arg) = case key of
 310         "include" -> case inH of
 311             Nothing -> outOption ("-#include "++arg)
 312             Just _  -> ""
 313         "define" -> case inH of
 314             Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
 315             _ -> ""
 316         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 317         _ -> ""
 318     goodForOptD arg = case arg of
 319         ""              -> True
 320         c:_ | isSpace c -> True
 321         '(':_           -> False
 322         _:s             -> goodForOptD s
 323     toOptD arg = case break isSpace arg of
 324         (name, "")      -> name
 325         (name, _:value) -> name++'=':dropWhile isSpace value
 326     includeH = concat [
 327         outOption ("-#include "++name++"")
 328         | name <- case inH of
 329             Nothing   -> [name | Include name <- flags]
 330             Just name -> ["\""++name++"\""]]
 331     outOption s = "    printf (\"{-# OPTIONS %s #-}\\n\", \""++
 332                   showCString s++"\");\n"
 333
 334 outTokenHs :: Token -> String
 335 outTokenHs (Text pos text) =
 336     case break (== '\n') text of
 337         (all, [])       -> outText all
 338         (first, _:rest) ->
 339             outText (first++"\n")++
 340             outHsLine pos++
 341             outText rest
 342     where
 343     outText s = "    fputs (\""++showCString s++"\", stdout);\n"
 344 outTokenHs (Special pos key arg) =
 345     case key of
 346         "include"           -> ""
 347         "define"            -> ""
 348         "undef"             -> ""
 349         "def"               -> ""
 350         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 351         "let"               -> ""
 352         "enum"              -> outCLine pos++outEnum arg
 353         _                   -> outCLine pos++"    hsc_"++key++" ("++arg++");\n"
 354
 355 outEnum :: String -> String
 356 outEnum arg =
 357     case break (== ',') arg of
 358         (_, [])        -> ""
 359         (t, _:afterT) -> case break (== ',') afterT of
 360             (f, afterF) -> let
 361                 enums []    = ""
 362                 enums (_:s) = case break (== ',') s of
 363                     (enum, rest) -> let
 364                         this = case break (== '=') $ dropWhile isSpace enum of
 365                             (name, []) ->
 366                                 "    hsc_enum ("++t++", "++f++", \
 367                                 \hsc_haskellize (\""++name++"\"), "++
 368                                 name++");\n"
 369                             (hsName, _:cName) ->
 370                                 "    hsc_enum ("++t++", "++f++", \
 371                                 \printf (\"%s\", \""++hsName++"\"), "++
 372                                 cName++");\n"
 373                         in this++enums rest
 374                 in enums afterF
 375
 376 outTokenH :: (SourcePos, String, String) -> String
 377 outTokenH (pos, key, arg) =
 378     case key of
 379         "include" -> outCLine pos++"#include "++arg++"\n"
 380         "define"  -> outCLine pos++"#define " ++arg++"\n"
 381         "undef"   -> outCLine pos++"#undef "  ++arg++"\n"
 382         "def"     -> outCLine pos++case arg of
 383             's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 384             't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 385             'i':'n':'l':'i':'n':'e':' ':_ ->
 386                 "#ifdef __GNUC__\n\
 387                 \extern\n\
 388                 \#endif\n"++
 389                 arg++"\n"
 390             _ -> "extern "++header++";\n"
 391             where header = takeWhile (\c -> c /= '{' && c /= '=') arg
 392         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 393         _ -> ""
 394
 395 outTokenC :: (SourcePos, String, String) -> String
 396 outTokenC (pos, key, arg) =
 397     case key of
 398         "def" -> case arg of
 399             's':'t':'r':'u':'c':'t':' ':_ -> ""
 400             't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
 401             'i':'n':'l':'i':'n':'e':' ':_ ->
 402                 outCLine pos++
 403                 "#ifndef __GNUC__\n\
 404                 \extern\n\
 405                 \#endif\n"++
 406                 header++
 407                 "\n#ifndef __GNUC__\n\
 408                 \;\n\
 409                 \#else\n"++
 410                 body++
 411                 "\n#endif\n"
 412             _ -> outCLine pos++arg++"\n"
 413             where (header, body) = span (\c -> c /= '{' && c /= '=') arg
 414         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 415         _ -> ""
 416
 417 conditional :: String -> Bool
 418 conditional "if"      = True
 419 conditional "ifdef"   = True
 420 conditional "ifndef"  = True
 421 conditional "elif"    = True
 422 conditional "else"    = True
 423 conditional "endif"   = True
 424 conditional "error"   = True
 425 conditional "warning" = True
 426 conditional _         = False
 427
 428 sourceFileName :: SourcePos -> String
 429 sourceFileName pos = fileName (sourceName pos)
 430     where
 431     fileName s = case break (== '/') s of
 432         (name, [])      -> name
 433         (_,     _:rest) -> fileName rest
 434
 435 outCLine :: SourcePos -> String
 436 outCLine pos =
 437     "# "++show (sourceLine pos)++
 438     " \""++showCString (sourceFileName pos)++"\"\n"
 439
 440 outHsLine :: SourcePos -> String
 441 outHsLine pos =
 442     "    hsc_line ("++
 443     show (sourceLine pos + 1)++", \""++
 444     showCString (sourceFileName pos)++"\");\n"
 445
 446 showCString :: String -> String
 447 showCString = concatMap showCChar
 448     where
 449     showCChar '\"' = "\\\""
 450     showCChar '\'' = "\\\'"
 451     showCChar '?'  = "\\?"
 452     showCChar '\\' = "\\\\"
 453     showCChar c | c >= ' ' && c <= '~' = [c]
 454     showCChar '\a' = "\\a"
 455     showCChar '\b' = "\\b"
 456     showCChar '\f' = "\\f"
 457     showCChar '\n' = "\\n\"\n           \""
 458     showCChar '\r' = "\\r"
 459     showCChar '\t' = "\\t"
 460     showCChar '\v' = "\\v"
 461     showCChar c    = ['\\',
 462                       intToDigit (ord c `quot` 64),
 463                       intToDigit (ord c `quot` 8 `mod` 8),
 464                       intToDigit (ord c          `mod` 8)]