ghc/utils/hsc2hs/Main.hs

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