ghc/utils/hsc2hs/Main.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: Main.hs,v 1.18 2001/02/13 15:09:02 rrt 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)
  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 #ifndef mingw32_TARGET_OS
 217         []  -> return "gcc"
 218 #else
 219         []  -> return "gcc -mno-cygwin"
 220 #endif
 221         [l] -> return l
 222         _   -> onlyOne "linker"
 223
 224     writeFile cProgName $
 225         concat ["#include \""++t++"\"\n" | Template t <- flags]++
 226         concat ["#include "++f++"\n"     | Include  f <- flags]++
 227         outHeaderCProg specials++
 228         "\nint main (void)\n{\n"++
 229         outHeaderHs flags (if needsH then Just outHName else Nothing) specials++
 230         outHsLine (newPos name 0 1)++
 231         concatMap outTokenHs toks++
 232         "    return 0;\n}\n"
 233
 234     compilerStatus <- system $
 235         compiler++
 236         " -c"++
 237         concat [" "++f | CompFlag f <- flags]++
 238         " "++cProgName++
 239         " -o "++oProgName
 240     case compilerStatus of
 241         e@(ExitFailure _) -> exitWith e
 242         _                 -> return ()
 243     removeFile cProgName
 244
 245     linkerStatus <- system $
 246         linker++
 247         concat [" "++f | LinkFlag f <- flags]++
 248         " "++oProgName++
 249         " -o "++progName
 250     case linkerStatus of
 251         e@(ExitFailure _) -> exitWith e
 252         _                 -> return ()
 253     removeFile oProgName
 254
 255     system (execProgName++" >"++outHsName)
 256     removeFile progName
 257
 258     when needsH $ writeFile outHName $
 259         "#ifndef "++includeGuard++"\n\
 260         \#define "++includeGuard++"\n\
 261         \#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 262         \#include <Rts.h>\n\
 263         \#endif\n\
 264         \#include <HsFFI.h>\n\
 265         \#if __NHC__\n\
 266         \#undef HsChar\n\
 267         \#define HsChar int\n\
 268         \#endif\n"++
 269         concat ["#include "++n++"\n" | Include n <- flags]++
 270         concatMap outTokenH specials++
 271         "#endif\n"
 272
 273     when needsC $ writeFile outCName $
 274         "#include \""++outHName++"\"\n"++
 275         concatMap outTokenC specials
 276
 277 onlyOne :: String -> IO a
 278 onlyOne what = do
 279     putStrLn ("Only one "++what++" may be specified")
 280     exitFailure
 281
 282 outHeaderCProg :: [(SourcePos, String, String)] -> String
 283 outHeaderCProg =
 284     concatMap $ \(pos, key, arg) -> case key of
 285         "include"           -> outCLine pos++"#include "++arg++"\n"
 286         "define"            -> outCLine pos++"#define "++arg++"\n"
 287         "undef"             -> outCLine pos++"#undef "++arg++"\n"
 288         "def"               -> case arg of
 289             's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
 290             't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
 291             _ -> ""
 292         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 293         "let"               -> case break (== '=') arg of
 294             (_,      "")     -> ""
 295             (header, _:body) -> case break isSpace header of
 296                 (name, args) ->
 297                     outCLine pos++
 298                     "#define hsc_"++name++"("++dropWhile isSpace args++") \
 299                     \printf ("++joinLines body++");\n"
 300         _ -> ""
 301     where
 302     joinLines = concat . intersperse " \\\n" . lines
 303
 304 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
 305 outHeaderHs flags inH toks =
 306     "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 307     \    printf (\"{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d #-}\\n\", \
 308     \__GLASGOW_HASKELL__);\n\
 309     \#endif\n"++
 310     includeH++
 311     concatMap outSpecial toks
 312     where
 313     outSpecial (pos, key, arg) = case key of
 314         "include" -> case inH of
 315             Nothing -> outOption ("-#include "++arg)
 316             Just _  -> ""
 317         "define" -> case inH of
 318             Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
 319             _ -> ""
 320         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 321         _ -> ""
 322     goodForOptD arg = case arg of
 323         ""              -> True
 324         c:_ | isSpace c -> True
 325         '(':_           -> False
 326         _:s             -> goodForOptD s
 327     toOptD arg = case break isSpace arg of
 328         (name, "")      -> name
 329         (name, _:value) -> name++'=':dropWhile isSpace value
 330     includeH = concat [
 331         outOption ("-#include "++name++"")
 332         | name <- case inH of
 333             Nothing   -> [name | Include name <- flags]
 334             Just name -> ["\""++name++"\""]]
 335     outOption s = "    printf (\"{-# OPTIONS %s #-}\\n\", \""++
 336                   showCString s++"\");\n"
 337
 338 outTokenHs :: Token -> String
 339 outTokenHs (Text pos text) =
 340     case break (== '\n') text of
 341         (all, [])       -> outText all
 342         (first, _:rest) ->
 343             outText (first++"\n")++
 344             outHsLine pos++
 345             outText rest
 346     where
 347     outText s = "    fputs (\""++showCString s++"\", stdout);\n"
 348 outTokenHs (Special pos key arg) =
 349     case key of
 350         "include"           -> ""
 351         "define"            -> ""
 352         "undef"             -> ""
 353         "def"               -> ""
 354         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 355         "let"               -> ""
 356         "enum"              -> outCLine pos++outEnum arg
 357         _                   -> outCLine pos++"    hsc_"++key++" ("++arg++");\n"
 358
 359 outEnum :: String -> String
 360 outEnum arg =
 361     case break (== ',') arg of
 362         (_, [])        -> ""
 363         (t, _:afterT) -> case break (== ',') afterT of
 364             (f, afterF) -> let
 365                 enums []    = ""
 366                 enums (_:s) = case break (== ',') s of
 367                     (enum, rest) -> let
 368                         this = case break (== '=') $ dropWhile isSpace enum of
 369                             (name, []) ->
 370                                 "    hsc_enum ("++t++", "++f++", \
 371                                 \hsc_haskellize (\""++name++"\"), "++
 372                                 name++");\n"
 373                             (hsName, _:cName) ->
 374                                 "    hsc_enum ("++t++", "++f++", \
 375                                 \printf (\"%s\", \""++hsName++"\"), "++
 376                                 cName++");\n"
 377                         in this++enums rest
 378                 in enums afterF
 379
 380 outTokenH :: (SourcePos, String, String) -> String
 381 outTokenH (pos, key, arg) =
 382     case key of
 383         "include" -> outCLine pos++"#include "++arg++"\n"
 384         "define"  -> outCLine pos++"#define " ++arg++"\n"
 385         "undef"   -> outCLine pos++"#undef "  ++arg++"\n"
 386         "def"     -> outCLine pos++case arg of
 387             's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 388             't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 389             'i':'n':'l':'i':'n':'e':' ':_ ->
 390                 "#ifdef __GNUC__\n\
 391                 \extern\n\
 392                 \#endif\n"++
 393                 arg++"\n"
 394             _ -> "extern "++header++";\n"
 395             where header = takeWhile (\c -> c /= '{' && c /= '=') arg
 396         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 397         _ -> ""
 398
 399 outTokenC :: (SourcePos, String, String) -> String
 400 outTokenC (pos, key, arg) =
 401     case key of
 402         "def" -> case arg of
 403             's':'t':'r':'u':'c':'t':' ':_ -> ""
 404             't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
 405             'i':'n':'l':'i':'n':'e':' ':_ ->
 406                 outCLine pos++
 407                 "#ifndef __GNUC__\n\
 408                 \extern\n\
 409                 \#endif\n"++
 410                 header++
 411                 "\n#ifndef __GNUC__\n\
 412                 \;\n\
 413                 \#else\n"++
 414                 body++
 415                 "\n#endif\n"
 416             _ -> outCLine pos++arg++"\n"
 417             where (header, body) = span (\c -> c /= '{' && c /= '=') arg
 418         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 419         _ -> ""
 420
 421 conditional :: String -> Bool
 422 conditional "if"      = True
 423 conditional "ifdef"   = True
 424 conditional "ifndef"  = True
 425 conditional "elif"    = True
 426 conditional "else"    = True
 427 conditional "endif"   = True
 428 conditional "error"   = True
 429 conditional "warning" = True
 430 conditional _         = False
 431
 432 sourceFileName :: SourcePos -> String
 433 sourceFileName pos = fileName (sourceName pos)
 434     where
 435     fileName s = case break (== '/') s of
 436         (name, [])      -> name
 437         (_,     _:rest) -> fileName rest
 438
 439 outCLine :: SourcePos -> String
 440 outCLine pos =
 441     "# "++show (sourceLine pos)++
 442     " \""++showCString (sourceFileName pos)++"\"\n"
 443
 444 outHsLine :: SourcePos -> String
 445 outHsLine pos =
 446     "    hsc_line ("++
 447     show (sourceLine pos + 1)++", \""++
 448     showCString (sourceFileName pos)++"\");\n"
 449
 450 showCString :: String -> String
 451 showCString = concatMap showCChar
 452     where
 453     showCChar '\"' = "\\\""
 454     showCChar '\'' = "\\\'"
 455     showCChar '?'  = "\\?"
 456     showCChar '\\' = "\\\\"
 457     showCChar c | c >= ' ' && c <= '~' = [c]
 458     showCChar '\a' = "\\a"
 459     showCChar '\b' = "\\b"
 460     showCChar '\f' = "\\f"
 461     showCChar '\n' = "\\n\"\n           \""
 462     showCChar '\r' = "\\r"
 463     showCChar '\t' = "\\t"
 464     showCChar '\v' = "\\v"
 465     showCChar c    = ['\\',
 466                       intToDigit (ord c `quot` 64),
 467                       intToDigit (ord c `quot` 8 `mod` 8),
 468                       intToDigit (ord c          `mod` 8)]