ghc/utils/hsc2hs/Main.hs

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