ghc/utils/hsc2hs/Main.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: Main.hs,v 1.22 2001/02/22 22:39:56 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     | 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     key <- liftM2 (:) (letter <|> char '_') (many (alphaNum <|> char '_'))
 149         <?> "hsc directive"
 150     skipMany (oneOf " \t")
 151     arg <- argument pzero
 152     return (Special pos key arg)
 153
 154 argument :: Parser String -> Parser String
 155 argument eol =
 156     liftM concat $ many
 157     (   many1 (noneOf "\n\"\'()/[\\]{}")
 158     <|> eol
 159     <|> (do char '\"'; a <- cString '\"'; char '\"'; return ("\""++a++"\""))
 160     <|> (do char '\''; a <- cString '\''; char '\''; return ("\'"++a++"\'"))
 161     <|> (do char '('; a <- nested; char ')'; return ("("++a++")"))
 162     <|> (do try (string "/*"); cComment; return " ")
 163     <|> (do try (string "//"); skipMany (satisfy (/= '\n')); return " ")
 164     <|> string "/"
 165     <|> (do char '['; a <- nested; char ']'; return ("["++a++"]"))
 166     <|> (do char '\\'; a <- anyChar; return $ if a == '\n' then [] else ['\\',a])
 167     <|> (do char '{'; a <- nested; char '}'; return ("{"++a++"}"))
 168     <?> "C expression")
 169     where nested = argument (string "\n")
 170
 171 cComment :: Parser ()
 172 cComment =
 173     (   (do skipMany1 (noneOf "*"); cComment)
 174     <|> (do try (string "*/"); return ())
 175     <|> (do char '*'; cComment)
 176     <?> "C comment")
 177
 178 cString :: Char -> Parser String
 179 cString quote =
 180     liftM concat $ many
 181     (   many1 (noneOf (quote:"\n\\"))
 182     <|> (do char '\\'; a <- anyChar; return ['\\',a])
 183     <?> "C character or string")
 184
 185 output :: [Flag] -> String -> [Token] -> IO ()
 186 output flags name toks = let
 187     baseName = case reverse name of
 188         'c':base -> reverse base
 189         _        -> name++".hs"
 190     cProgName = baseName++"_make.c"
 191     oProgName = baseName++"_make.o"
 192     progName  = baseName++"_make"
 193     outHsName = baseName
 194     outHName  = baseName++".h"
 195     outCName  = baseName++".c"
 196
 197     execProgName = case progName of
 198         '/':_ -> progName
 199         _     -> "./"++progName
 200
 201     specials = [(pos, key, arg) | Special pos key arg <- toks]
 202
 203     needsC = any (\(_, key, _) -> key == "def") specials
 204     needsH = needsC
 205
 206     includeGuard = map fixChar outHName
 207         where
 208         fixChar c | isAlphaNum c = toUpper c
 209                   | otherwise    = '_'
 210
 211     in do
 212
 213     compiler <- case [c | Compiler c <- flags] of
 214         []  -> return "ghc"
 215         [c] -> return c
 216         _   -> onlyOne "compiler"
 217     linker <- case [l | Linker l <- flags] of
 218         []  -> return defaultCompiler
 219         [l] -> return l
 220         _   -> onlyOne "linker"
 221
 222     writeFile cProgName $
 223         concat ["#include \""++t++"\"\n" | Template t <- flags]++
 224         concat ["#include "++f++"\n"     | Include  f <- flags]++
 225         outHeaderCProg specials++
 226         "\nint main (void)\n{\n"++
 227         outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
 228         outHsLine (newPos name 0 1)++
 229         concatMap outTokenHs toks++
 230         "    return 0;\n}\n"
 231
 232     compilerStatus <- system $
 233         compiler++
 234         " -c"++
 235         concat [" "++f | CompFlag f <- flags]++
 236         " "++cProgName++
 237         " -o "++oProgName
 238     case compilerStatus of
 239         e@(ExitFailure _) -> exitWith e
 240         _                 -> return ()
 241     when (null [() | Keep <- flags]) $ removeFile cProgName
 242
 243     linkerStatus <- system $
 244         linker++
 245         concat [" "++f | LinkFlag f <- flags]++
 246         " "++oProgName++
 247         " -o "++progName
 248     case linkerStatus of
 249         e@(ExitFailure _) -> exitWith e
 250         _                 -> return ()
 251     removeFile oProgName
 252
 253     system (execProgName++" >"++outHsName)
 254     removeFile progName
 255
 256     when needsH $ writeFile outHName $
 257         "#ifndef "++includeGuard++"\n\
 258         \#define "++includeGuard++"\n\
 259         \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 260         \#include <Rts.h>\n\
 261         \#endif\n\
 262         \#include <HsFFI.h>\n\
 263         \#if __NHC__\n\
 264         \#undef HsChar\n\
 265         \#define HsChar int\n\
 266         \#endif\n"++
 267         concat ["#include "++n++"\n" | Include n <- flags]++
 268         concatMap outTokenH specials++
 269         "#endif\n"
 270
 271     when needsC $ writeFile outCName $
 272         "#include \""++outHName++"\"\n"++
 273         concatMap outTokenC specials
 274
 275 onlyOne :: String -> IO a
 276 onlyOne what = do
 277     putStrLn ("Only one "++what++" may be specified")
 278     exitFailure
 279
 280 outHeaderCProg :: [(SourcePos, String, String)] -> String
 281 outHeaderCProg =
 282     concatMap $ \(pos, key, arg) -> case key of
 283         "include"           -> outCLine pos++"#include "++arg++"\n"
 284         "define"            -> outCLine pos++"#define "++arg++"\n"
 285         "undef"             -> outCLine pos++"#undef "++arg++"\n"
 286         "def"               -> case arg of
 287             's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
 288             't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
 289             _ -> ""
 290         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 291         "let"               -> case break (== '=') arg of
 292             (_,      "")     -> ""
 293             (header, _:body) -> case break isSpace header of
 294                 (name, args) ->
 295                     outCLine pos++
 296                     "#define hsc_"++name++"("++dropWhile isSpace args++") \
 297                     \printf ("++joinLines body++");\n"
 298         _ -> ""
 299     where
 300     joinLines = concat . intersperse " \\\n" . lines
 301
 302 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
 303 outHeaderHs flags inH toks =
 304     "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 305     \    printf (\"{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d #-}\\n\", \
 306     \__GLASGOW_HASKELL__);\n\
 307     \#endif\n"++
 308     includeH++
 309     concatMap outSpecial toks
 310     where
 311     outSpecial (pos, key, arg) = case key of
 312         "include" -> case inH of
 313             Nothing -> outOption ("-#include "++arg)
 314             Just _  -> ""
 315         "define" -> case inH of
 316             Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
 317             _ -> ""
 318         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 319         _ -> ""
 320     goodForOptD arg = case arg of
 321         ""              -> True
 322         c:_ | isSpace c -> True
 323         '(':_           -> False
 324         _:s             -> goodForOptD s
 325     toOptD arg = case break isSpace arg of
 326         (name, "")      -> name
 327         (name, _:value) -> name++'=':dropWhile isSpace value
 328     includeH = concat [
 329         outOption ("-#include "++name++"")
 330         | name <- case inH of
 331             Nothing   -> [name | Include name <- flags]
 332             Just name -> ["\""++name++"\""]]
 333     outOption s = "    printf (\"{-# OPTIONS %s #-}\\n\", \""++
 334                   showCString s++"\");\n"
 335
 336 outTokenHs :: Token -> String
 337 outTokenHs (Text pos text) =
 338     case break (== '\n') text of
 339         (all, [])       -> outText all
 340         (first, _:rest) ->
 341             outText (first++"\n")++
 342             outHsLine pos++
 343             outText rest
 344     where
 345     outText s = "    fputs (\""++showCString s++"\", stdout);\n"
 346 outTokenHs (Special pos key arg) =
 347     case key of
 348         "include"           -> ""
 349         "define"            -> ""
 350         "undef"             -> ""
 351         "def"               -> ""
 352         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 353         "let"               -> ""
 354         "enum"              -> outCLine pos++outEnum arg
 355         _                   -> outCLine pos++"    hsc_"++key++" ("++arg++");\n"
 356
 357 outEnum :: String -> String
 358 outEnum arg =
 359     case break (== ',') arg of
 360         (_, [])        -> ""
 361         (t, _:afterT) -> case break (== ',') afterT of
 362             (f, afterF) -> let
 363                 enums []    = ""
 364                 enums (_:s) = case break (== ',') s of
 365                     (enum, rest) -> let
 366                         this = case break (== '=') $ dropWhile isSpace enum of
 367                             (name, []) ->
 368                                 "    hsc_enum ("++t++", "++f++", \
 369                                 \hsc_haskellize (\""++name++"\"), "++
 370                                 name++");\n"
 371                             (hsName, _:cName) ->
 372                                 "    hsc_enum ("++t++", "++f++", \
 373                                 \printf (\"%s\", \""++hsName++"\"), "++
 374                                 cName++");\n"
 375                         in this++enums rest
 376                 in enums afterF
 377
 378 outTokenH :: (SourcePos, String, String) -> String
 379 outTokenH (pos, key, arg) =
 380     case key of
 381         "include" -> outCLine pos++"#include "++arg++"\n"
 382         "define"  -> outCLine pos++"#define " ++arg++"\n"
 383         "undef"   -> outCLine pos++"#undef "  ++arg++"\n"
 384         "def"     -> outCLine pos++case arg of
 385             's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 386             't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 387             'i':'n':'l':'i':'n':'e':' ':_ ->
 388                 "#ifdef __GNUC__\n\
 389                 \extern\n\
 390                 \#endif\n"++
 391                 arg++"\n"
 392             _ -> "extern "++header++";\n"
 393             where header = takeWhile (\c -> c /= '{' && c /= '=') arg
 394         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 395         _ -> ""
 396
 397 outTokenC :: (SourcePos, String, String) -> String
 398 outTokenC (pos, key, arg) =
 399     case key of
 400         "def" -> case arg of
 401             's':'t':'r':'u':'c':'t':' ':_ -> ""
 402             't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
 403             'i':'n':'l':'i':'n':'e':' ':_ ->
 404                 outCLine pos++
 405                 "#ifndef __GNUC__\n\
 406                 \extern\n\
 407                 \#endif\n"++
 408                 header++
 409                 "\n#ifndef __GNUC__\n\
 410                 \;\n\
 411                 \#else\n"++
 412                 body++
 413                 "\n#endif\n"
 414             _ -> outCLine pos++arg++"\n"
 415             where (header, body) = span (\c -> c /= '{' && c /= '=') arg
 416         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 417         _ -> ""
 418
 419 conditional :: String -> Bool
 420 conditional "if"      = True
 421 conditional "ifdef"   = True
 422 conditional "ifndef"  = True
 423 conditional "elif"    = True
 424 conditional "else"    = True
 425 conditional "endif"   = True
 426 conditional "error"   = True
 427 conditional "warning" = True
 428 conditional _         = False
 429
 430 sourceFileName :: SourcePos -> String
 431 sourceFileName pos = fileName (sourceName pos)
 432     where
 433     fileName s = case break (== '/') s of
 434         (name, [])      -> name
 435         (_,     _:rest) -> fileName rest
 436
 437 outCLine :: SourcePos -> String
 438 outCLine pos =
 439     "# "++show (sourceLine pos)++
 440     " \""++showCString (sourceFileName pos)++"\"\n"
 441
 442 outHsLine :: SourcePos -> String
 443 outHsLine pos =
 444     "    hsc_line ("++
 445     show (sourceLine pos + 1)++", \""++
 446     showCString (sourceFileName pos)++"\");\n"
 447
 448 showCString :: String -> String
 449 showCString = concatMap showCChar
 450     where
 451     showCChar '\"' = "\\\""
 452     showCChar '\'' = "\\\'"
 453     showCChar '?'  = "\\?"
 454     showCChar '\\' = "\\\\"
 455     showCChar c | c >= ' ' && c <= '~' = [c]
 456     showCChar '\a' = "\\a"
 457     showCChar '\b' = "\\b"
 458     showCChar '\f' = "\\f"
 459     showCChar '\n' = "\\n\"\n           \""
 460     showCChar '\r' = "\\r"
 461     showCChar '\t' = "\\t"
 462     showCChar '\v' = "\\v"
 463     showCChar c    = ['\\',
 464                       intToDigit (ord c `quot` 64),
 465                       intToDigit (ord c `quot` 8 `mod` 8),
 466                       intToDigit (ord c          `mod` 8)]