ghc/utils/hsc2hs/Main.hs

   1 {-# OPTIONS -cpp #-}
   2
   3 -----------------------------------------------------------------------------
   4 -- $Id: Main.hs,v 1.20 2001/02/13 16:11:27 rrt Exp $
   5 --
   6 -- (originally "GlueHsc.hs" by Marcin 'Qrczak' Kowalczyk)
   7 --
   8 -- Program for converting .hsc files to .hs files, by converting the
   9 -- file into a C program which is run to generate the Haskell source.
  10 -- Certain items known only to the C compiler can then be used in
  11 -- the Haskell module; for example #defined constants, byte offsets
  12 -- within structures, etc.
  13 --
  14 -- See the documentation in the Users' Guide for more details.
  15
  16 #include "../../includes/config.h"
  17
  18 import GetOpt
  19 import System        (getProgName, getArgs, ExitCode(..), exitWith, exitFailure)
  20 import KludgedSystem (system, defaultCompiler)
  21 import Directory     (removeFile)
  22 import Parsec
  23 import ParsecError
  24 import Monad         (liftM, liftM2, when)
  25 import Char          (ord, intToDigit, isSpace, isAlpha, isAlphaNum, toUpper)
  26 import List          (intersperse)
  27
  28 version :: String
  29 version = "hsc2hs-0.64"
  30
  31 data Flag
  32     = Help
  33     | Version
  34     | Template String
  35     | Compiler String
  36     | Linker   String
  37     | CompFlag String
  38     | LinkFlag String
  39     | Include  String
  40
  41 include :: String -> Flag
  42 include s@('\"':_) = Include s
  43 include s@('<' :_) = Include s
  44 include s          = Include ("\""++s++"\"")
  45
  46 options :: [OptDescr Flag]
  47 options = [
  48     Option "t" ["template"] (ReqArg Template   "FILE") "template file",
  49     Option ""  ["cc"]       (ReqArg Compiler   "PROG") "C compiler to use",
  50     Option ""  ["ld"]       (ReqArg Linker     "PROG") "linker to use",
  51     Option ""  ["cflag"]    (ReqArg CompFlag   "FLAG") "flag to pass to the C compiler",
  52     Option "I" []           (ReqArg (CompFlag . ("-I"++))
  53                                                "DIR")  "passed to the C compiler",
  54     Option ""  ["lflag"]    (ReqArg LinkFlag   "FLAG") "flag to pass to the linker",
  55     Option ""  ["include"]  (ReqArg include    "FILE") "as if placed in the source",
  56     Option ""  ["help"]     (NoArg  Help)              "display this help and exit",
  57     Option ""  ["version"]  (NoArg  Version)           "output version information and exit"]
  58
  59 main :: IO ()
  60 main = do
  61     prog <- getProgName
  62     let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]"
  63     args <- getArgs
  64     case getOpt Permute options args of
  65         (flags, _, _)
  66             | any isHelp    flags -> putStrLn (usageInfo header options)
  67             | any isVersion flags -> putStrLn version
  68             where
  69             isHelp    Help    = True; isHelp    _ = False
  70             isVersion Version = True; isVersion _ = False
  71         (_,     [],    [])   -> putStrLn (prog++": No input files")
  72         (flags, files, [])   -> mapM_ (processFile flags) files
  73         (_,     _,     errs) -> do
  74             mapM_ putStrLn errs
  75             putStrLn (usageInfo header options)
  76             exitFailure
  77
  78 processFile :: [Flag] -> String -> IO ()
  79 processFile flags name = do
  80     parsed <- parseFromFile parser name
  81     case parsed of
  82         Left err   -> do print err; exitFailure
  83         Right toks -> output flags name toks
  84
  85 data Token
  86     = Text    SourcePos String
  87     | Special SourcePos String String
  88
  89 parser :: Parser [Token]
  90 parser = many (text <|> special)
  91
  92 text :: Parser Token
  93 text = do
  94     pos <- getPosition
  95     liftM (Text pos . concat) $ many1
  96         (   many1 (satisfy (\ch -> not (isAlpha ch || ch `elem` "\"#'-_{")))
  97         <|> (do a <- satisfy (\ch -> isAlpha ch || ch == '_')
  98                 b <- many (satisfy (\ch -> isAlphaNum ch || ch == '_' || ch == '\''))
  99                 return (a:b))
 100         <|> (do char '\"'; a <- hsString '\"'; char '\"'; return ("\""++a++"\""))
 101         <|> (do try (string "##"); return "#")
 102         <|> (do char '\''; a <- hsString '\''; char '\''; return ("\'"++a++"\'"))
 103         <|> (do try (string "--"); a <- many (satisfy (/= '\n')); return ("--"++a))
 104         <|> string "-"
 105         <|> (do try (string "{-#"); optional (try linePragma); a <- hsComment; return ("{-#"++a))
 106         <|> (do try (string "{-"); a <- hsComment; return ("{-"++a))
 107         <|> string "{"
 108         <?> "Haskell source")
 109
 110 linePragma :: Parser ()
 111 linePragma = do
 112     state <- getState
 113     spaces
 114     string "LINE"
 115     skipMany1 space
 116     line <- many1 digit
 117     skipMany1 space
 118     char '\"'
 119     file <- many (satisfy (/= '\"'))
 120     char '\"'
 121     spaces
 122     string "#-}"
 123     setState state
 124     setPosition (newPos file (read line - 1) 1)
 125
 126 hsComment :: Parser String
 127 hsComment =
 128     (   (do a <- many1 (noneOf "-{"); b <- hsComment; return (a++b))
 129     <|> try (string "-}")
 130     <|> (do char '-'; b <- hsComment; return ('-':b))
 131     <|> (do try (string "{-"); a <- hsComment; b <- hsComment; return ("{-"++a++b))
 132     <|> (do char '{'; b <- hsComment; return ('{':b))
 133     <?> "Haskell comment")
 134
 135 hsString :: Char -> Parser String
 136 hsString quote =
 137     liftM concat $ many
 138     (   many1 (noneOf (quote:"\n\\"))
 139     <|> (do char '\\'; a <- escape; return ('\\':a))
 140     <?> "Haskell character or string")
 141     where
 142     escape = (do a <- many1 (satisfy isSpace); char '\\'; return (a++"\\"))
 143          <|> (do a <- anyChar; return [a])
 144
 145 special :: Parser Token
 146 special = do
 147     pos <- getPosition
 148     char '#'
 149     skipMany (oneOf " \t")
 150     key <- liftM2 (:) (letter <|> char '_') (many (alphaNum <|> char '_'))
 151         <?> "hsc directive"
 152     skipMany (oneOf " \t")
 153     arg <- argument pzero
 154     return (Special pos key arg)
 155
 156 argument :: Parser String -> Parser String
 157 argument eol =
 158     liftM concat $ many
 159     (   many1 (noneOf "\n\"\'()/[\\]{}")
 160     <|> eol
 161     <|> (do char '\"'; a <- cString '\"'; char '\"'; return ("\""++a++"\""))
 162     <|> (do char '\''; a <- cString '\''; char '\''; return ("\'"++a++"\'"))
 163     <|> (do char '('; a <- nested; char ')'; return ("("++a++")"))
 164     <|> (do try (string "/*"); cComment; return " ")
 165     <|> (do try (string "//"); skipMany (satisfy (/= '\n')); return " ")
 166     <|> string "/"
 167     <|> (do char '['; a <- nested; char ']'; return ("["++a++"]"))
 168     <|> (do char '\\'; a <- anyChar; return $ if a == '\n' then [] else ['\\',a])
 169     <|> (do char '{'; a <- nested; char '}'; return ("{"++a++"}"))
 170     <?> "C expression")
 171     where nested = argument (string "\n")
 172
 173 cComment :: Parser ()
 174 cComment =
 175     (   (do skipMany1 (noneOf "*"); cComment)
 176     <|> (do try (string "*/"); return ())
 177     <|> (do char '*'; cComment)
 178     <?> "C comment")
 179
 180 cString :: Char -> Parser String
 181 cString quote =
 182     liftM concat $ many
 183     (   many1 (noneOf (quote:"\n\\"))
 184     <|> (do char '\\'; a <- anyChar; return ['\\',a])
 185     <?> "C character or string")
 186
 187 output :: [Flag] -> String -> [Token] -> IO ()
 188 output flags name toks = let
 189     baseName = case reverse name of
 190         'c':base -> reverse base
 191         _        -> name++".hs"
 192     cProgName = baseName++"c_make_hs.c"
 193     oProgName = baseName++"c_make_hs.o"
 194     progName  = baseName++"c_make_hs"
 195     outHsName = baseName
 196     outHName  = baseName++".h"
 197     outCName  = baseName++".c"
 198
 199     execProgName = case progName of
 200         '/':_ -> progName
 201         _     -> "./"++progName
 202
 203     specials = [(pos, key, arg) | Special pos key arg <- toks]
 204
 205     needsC = any (\(_, key, _) -> key == "def") specials
 206     needsH = needsC
 207
 208     includeGuard = map fixChar outHName
 209         where
 210         fixChar c | isAlphaNum c = toUpper c
 211                   | otherwise    = '_'
 212
 213     in do
 214
 215     compiler <- case [c | Compiler c <- flags] of
 216         []  -> return "ghc"
 217         [c] -> return c
 218         _   -> onlyOne "compiler"
 219     linker <- case [l | Linker l <- flags] of
 220         []  -> return defaultCompiler
 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)]