ghc/utils/hsc2hs/Main.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: Main.hs,v 1.12 2001/01/13 23:10:45 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) -> case key of
 276         "include"           -> outCLine pos++"#include "++arg++"\n"
 277         "define"            -> outCLine pos++"#define "++arg++"\n"
 278         "undef"             -> outCLine pos++"#undef "++arg++"\n"
 279         "def"               -> case arg of
 280             's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n"
 281             't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n"
 282             _ -> ""
 283         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 284         "let"               -> case break (== '=') arg of
 285             (_,      "")     -> ""
 286             (header, _:body) -> case break isSpace header of
 287                 (name, args) ->
 288                     outCLine pos++
 289                     "#define hsc_"++name++"("++dropWhile isSpace args++") \
 290                     \printf ("++joinLines body++");\n"
 291         _ -> ""
 292     where
 293     joinLines = concat . intersperse " \\\n" . lines
 294
 295 outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String
 296 outHeaderHs flags inH toks =
 297     "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n\
 298     \    printf (\"{-# OPTIONS -optc-D__GLASGOW_HASKELL__=%d #-}\\n\", \
 299     \__GLASGOW_HASKELL__);\n\
 300     \#endif\n"++
 301     includeH++
 302     concatMap outSpecial toks
 303     where
 304     outSpecial (pos, key, arg) = case key of
 305         "include" -> case inH of
 306             Nothing -> outOption ("-#include "++arg)
 307             Just _  -> ""
 308         "define" -> case inH of
 309             Nothing | goodForOptD arg -> outOption ("-optc-D"++toOptD arg)
 310             _ -> ""
 311         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 312         _ -> ""
 313     goodForOptD arg = case arg of
 314         ""              -> True
 315         c:_ | isSpace c -> True
 316         '(':_           -> False
 317         _:s             -> goodForOptD s
 318     toOptD arg = case break isSpace arg of
 319         (name, "")      -> name
 320         (name, _:value) -> name++'=':dropWhile isSpace value
 321     includeH = concat [
 322         outOption ("-#include "++name++"")
 323         | name <- case inH of
 324             Nothing   -> [name | Include name <- flags]
 325             Just name -> ["\""++name++"\""]]
 326     outOption s = "    printf (\"{-# OPTIONS %s #-}\\n\", \""++
 327                   showCString s++"\");\n"
 328
 329 outTokenHs :: Token -> String
 330 outTokenHs (Text pos text) =
 331     case break (== '\n') text of
 332         (all, [])       -> outText all
 333         (first, _:rest) ->
 334             outText (first++"\n")++
 335             outHsLine pos++
 336             outText rest
 337     where
 338     outText s = "    fputs (\""++showCString s++"\", stdout);\n"
 339 outTokenHs (Special pos key arg) =
 340     case key of
 341         "include"           -> ""
 342         "define"            -> ""
 343         "undef"             -> ""
 344         "def"               -> ""
 345         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 346         "let"               -> ""
 347         _                   -> outCLine pos++"    hsc_"++key++" ("++arg++");\n"
 348
 349 outTokenH :: (SourcePos, String, String) -> String
 350 outTokenH (pos, key, arg) =
 351     case key of
 352         "include" -> outCLine pos++"#include "++arg++"\n"
 353         "define"  -> outCLine pos++"#define " ++arg++"\n"
 354         "undef"   -> outCLine pos++"#undef "  ++arg++"\n"
 355         "def"     -> outCLine pos++case arg of
 356             's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 357             't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 358             'i':'n':'l':'i':'n':'e':' ':_ ->
 359                 "#ifdef __GNUC__\n\
 360                 \extern\n\
 361                 \#endif\n"++
 362                 arg++"\n"
 363             _ -> "extern "++header++";\n"
 364             where header = takeWhile (\c -> c/='{' && c/='=') arg
 365         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 366         _ -> ""
 367
 368 outTokenC :: (SourcePos, String, String) -> String
 369 outTokenC (pos, key, arg) =
 370     case key of
 371         "def" -> case arg of
 372             's':'t':'r':'u':'c':'t':' ':_ -> ""
 373             't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
 374             'i':'n':'l':'i':'n':'e':' ':_ ->
 375                 outCLine pos++
 376                 "#ifndef __GNUC__\n\
 377                 \extern\n\
 378                 \#endif\n"++
 379                 header++
 380                 "\n#ifndef __GNUC__\n\
 381                 \;\n\
 382                 \#else\n"++
 383                 body++
 384                 "\n#endif\n"
 385             _ -> outCLine pos++arg++"\n"
 386             where (header, body) = span (\c -> c/='{' && c/='=') arg
 387         _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n"
 388         _ -> ""
 389
 390 conditional :: String -> Bool
 391 conditional "if"     = True
 392 conditional "ifdef"  = True
 393 conditional "ifndef" = True
 394 conditional "elif"   = True
 395 conditional "else"   = True
 396 conditional "endif"  = True
 397 conditional "error"  = True
 398 conditional _        = False
 399
 400 sourceFileName :: SourcePos -> String
 401 sourceFileName pos = fileName (sourceName pos)
 402     where
 403     fileName s = case break (== '/') s of
 404         (name, [])      -> name
 405         (_,     _:rest) -> fileName rest
 406
 407 outCLine :: SourcePos -> String
 408 outCLine pos =
 409     "# "++show (sourceLine pos)++
 410     " \""++showCString (sourceFileName pos)++"\"\n"
 411
 412 outHsLine :: SourcePos -> String
 413 outHsLine pos =
 414     "    hsc_line ("++
 415     show (sourceLine pos + 1)++", \""++
 416     showCString (sourceFileName pos)++"\");\n"
 417
 418 showCString :: String -> String
 419 showCString = concatMap showCChar
 420     where
 421     showCChar '\"' = "\\\""
 422     showCChar '\'' = "\\\'"
 423     showCChar '?'  = "\\?"
 424     showCChar '\\' = "\\\\"
 425     showCChar c | c >= ' ' && c <= '~' = [c]
 426     showCChar '\a' = "\\a"
 427     showCChar '\b' = "\\b"
 428     showCChar '\f' = "\\f"
 429     showCChar '\n' = "\\n\"\n           \""
 430     showCChar '\r' = "\\r"
 431     showCChar '\t' = "\\t"
 432     showCChar '\v' = "\\v"
 433     showCChar c    = ['\\',
 434                       intToDigit (ord c `quot` 64),
 435                       intToDigit (ord c `quot` 8 `mod` 8),
 436                       intToDigit (ord c          `mod` 8)]