ghc/utils/hsc2hs/Main.hs

   1 -----------------------------------------------------------------------------
   2 -- $Id: Main.hs,v 1.2 2000/11/07 15:28:36 simonmar 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 Monad     (liftM, liftM2, when)
  19 import Char      (ord, intToDigit, isSpace, isAlphaNum, toUpper)
  20
  21 data Flag
  22     = Help
  23     | Template String
  24     | Compiler String
  25     | Linker String
  26     | CompFlag String
  27     | LinkFlag String
  28
  29 options :: [OptDescr Flag]
  30 options = [
  31     Option "t" ["template"] (ReqArg Template "FILE") "template file",
  32     Option ""  ["cc"]       (ReqArg Compiler "PROG") "C compiler to use",
  33     Option ""  ["ld"]       (ReqArg Linker   "PROG") "linker to use",
  34     Option ""  ["cflag"]    (ReqArg CompFlag "FLAG") "flag to pass to the C compiler",
  35     Option ""  ["lflag"]    (ReqArg LinkFlag "FLAG") "flag to pass to the linker",
  36     Option ""  ["help"]     (NoArg  Help)            "display this help and exit"]
  37
  38 main :: IO ()
  39 main = do
  40     prog <- getProgName
  41     let header = "Usage: "++prog++" [OPTIONS...] INPUT.hsc [...]"
  42     args <- getArgs
  43     case getOpt Permute options args of
  44         (flags, _, _) | any isHelp flags -> putStrLn (usageInfo header options)
  45             where isHelp Help = True; isHelp _ = False
  46         (_,     [],    [])   -> putStrLn (prog++": No input files")
  47         (flags, files, [])   -> mapM_ (processFile flags) files
  48         (_,     _,     errs) -> do
  49             mapM_ putStrLn errs
  50             putStrLn (usageInfo header options)
  51             exitFailure
  52
  53 processFile :: [Flag] -> String -> IO ()
  54 processFile flags name = do
  55     parsed <- parseFromFile parser name
  56     case parsed of
  57         Left err -> print err
  58         Right toks -> output flags name toks
  59
  60 data Token
  61     = Text String
  62     | Special String String
  63
  64 parser :: Parser [Token]
  65 parser = many (text <|> special)
  66
  67 text :: Parser Token
  68 text = liftM Text $ many1 $ satisfy (/= '#') <|> try (string "##" >> return '#')
  69
  70 special :: Parser Token
  71 special = do
  72     char '#'
  73     skipMany (oneOf " \t")
  74     key <- liftM2 (:) (letter <|> char '_') (many (alphaNum <|> char '_'))
  75         <?> "hsc directive"
  76     skipMany (oneOf " \t")
  77     arg <- argument pzero
  78     return (Special key arg)
  79
  80 argument :: Parser String -> Parser String
  81 argument eol = liftM concat $ many
  82     (   many1 (noneOf "\n\"\'()/[\\]{}")
  83     <|> eol
  84     <|> (do char '\"'; a <- cString '\''; char '\"'; return ("\""++a++"\""))
  85     <|> (do char '\''; a <- cString '\"'; char '\''; return ("\'"++a++"\'"))
  86     <|> (do char '('; a <- nested; char ')'; return ("("++a++")"))
  87     <|> (do try (string "/*"); comment; return " ")
  88     <|> (do try (string "//"); skipMany (satisfy (/= '\n')); return " ")
  89     <|> string "/"
  90     <|> (do char '['; a <- nested; char ']'; return ("["++a++"]"))
  91     <|> (do char '\\'; a <- anyChar; return ['\\',a])
  92     <|> (do char '{'; a <- nested; char '}'; return ("{"++a++"}"))
  93     <?> "C expression")
  94     where nested = argument (string "\n")
  95
  96 comment :: Parser ()
  97 comment = (do skipMany1 (noneOf "*"); comment)
  98       <|> (do try (string "*/"); return ())
  99       <|> (do char '*'; comment)
 100       <?> "C comment"
 101
 102 cString :: Char -> Parser String
 103 cString otherQuote = liftM concat $ many
 104     (   many1 (noneOf "\n\\\'\"")
 105     <|> string [otherQuote]
 106     <|> (do char '\\'; a <- anyChar; return ['\\',a])
 107     <?> "C character or string")
 108
 109 output :: [Flag] -> String -> [Token] -> IO ()
 110 output flags name toks = let
 111     baseName = case reverse name of
 112         'c':base -> reverse base
 113         _        -> name++".hs"
 114     cProgName = baseName++"c_make_hs.c"
 115     oProgName = baseName++"c_make_hs.o"
 116     progName  = baseName++"c_make_hs"
 117     outHsName = baseName
 118     outHName  = baseName++".h"
 119     outCName  = baseName++".c"
 120
 121     execProgName = case progName of
 122         '/':_ -> progName
 123         _     -> "./"++progName
 124
 125     specials = [(key, arg) | Special key arg <- toks]
 126
 127     needsC = any (\(key, _) -> key=="def") specials
 128     needsH = needsC
 129
 130     includeGuard = map fixChar outHName
 131         where
 132         fixChar c | isAlphaNum c = toUpper c
 133                   | otherwise    = '_'
 134
 135     in do
 136
 137     compiler <- case [c | Compiler c <- flags] of
 138         []  -> return "ghc"
 139         [c] -> return c
 140         _   -> onlyOne "compiler"
 141     linker <- case [l | Linker l <- flags] of
 142         []  -> return "gcc"
 143         [l] -> return l
 144         _   -> onlyOne "linker"
 145
 146     writeFile cProgName $
 147         concat ["#include \""++t++"\"\n" | Template t <- flags] ++
 148         outHeaderCProg specials ++
 149         "\nint main (void)\n{\n" ++
 150         outHeaderHs (if needsH then Just outHName else Nothing) specials ++
 151         concatMap outTokenHs toks ++
 152         "    return 0;\n}\n"
 153
 154     compilerStatus <- system $
 155         compiler++
 156         " -c"++
 157         concat [" "++f | CompFlag f <- flags]++
 158         " "++cProgName++
 159         " -o "++oProgName
 160     case compilerStatus of
 161         e@(ExitFailure _) -> exitWith e
 162         _                 -> return ()
 163     removeFile cProgName
 164
 165     linkerStatus <- system $
 166         linker++
 167         concat [" "++f | LinkFlag f <- flags]++
 168         " "++oProgName++
 169         " -o "++progName
 170     case linkerStatus of
 171         e@(ExitFailure _) -> exitWith e
 172         _                 -> return ()
 173     removeFile oProgName
 174
 175     system (execProgName++" >"++outHsName)
 176     removeFile progName
 177
 178     when needsH $ writeFile outHName $
 179         "#ifndef "++includeGuard++"\n\
 180         \#define "++includeGuard++"\n\
 181         \#include <HsFFI.h>\n"++
 182         concatMap outTokenH specials++
 183         "#endif\n"
 184
 185     when needsC $ writeFile outCName $
 186         "#include \""++outHName++"\"\n"++
 187         concatMap outTokenC specials
 188
 189 onlyOne :: String -> IO a
 190 onlyOne what = do
 191     putStrLn ("Only one "++what++" may be specified")
 192     exitFailure
 193
 194 outHeaderCProg :: [(String, String)] -> String
 195 outHeaderCProg = concatMap $ \(key, arg) -> case key of
 196     "include"           -> "#include "++arg++"\n"
 197     "define"            -> "#define "++arg++"\n"
 198     "def"               -> case arg of
 199         's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 200         't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 201         _ -> ""
 202     _ | conditional key -> "#"++key++" "++arg++"\n"
 203     _                   -> ""
 204
 205 outHeaderHs :: Maybe String -> [(String, String)] -> String
 206 outHeaderHs inH toks =
 207     concatMap outSpecial toks ++
 208     includeH ++
 209     "    hsc_end_options();\n\n"
 210     where
 211     outSpecial (key, arg) = case key of
 212         "include" -> case inH of
 213             Nothing -> out ("-#include "++arg)
 214             Just _  -> ""
 215         "define" -> case inH of
 216             Nothing -> out ("-optc-D"++toOptD arg)
 217             Just _  -> ""
 218         "option" -> out arg
 219         _ | conditional key -> "#"++key++" "++arg++"\n"
 220         _ -> ""
 221     toOptD arg = case break isSpace arg of
 222         (name, "")      -> name
 223         (name, _:value) -> name++'=':dropWhile isSpace value
 224     includeH = case inH of
 225         Nothing   -> ""
 226         Just name -> out ("-#include \""++name++"\"")
 227     out s = "    hsc_option (\""++showCString s++"\");\n"
 228
 229 outTokenHs :: Token -> String
 230 outTokenHs (Text s) = "    fputs (\""++showCString s++"\", stdout);\n"
 231 outTokenHs (Special key arg) = case key of
 232     "include"           -> ""
 233     "define"            -> ""
 234     "option"            -> ""
 235     "def"               -> ""
 236     _ | conditional key -> "#"++key++" "++arg++"\n"
 237     _                   -> "    hsc_"++key++" ("++arg++");\n"
 238
 239 outTokenH :: (String, String) -> String
 240 outTokenH (key, arg) = case key of
 241     "include" -> "#include "++arg++"\n"
 242     "define" -> "#define " ++arg++"\n"
 243     "def" -> case arg of
 244         's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n"
 245         't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n"
 246         'i':'n':'l':'i':'n':'e':' ':_ ->
 247             "#ifdef __GNUC__\n\
 248             \extern\n\
 249             \#endif\n"++
 250             arg++"\n"
 251         _ -> "extern "++header++";\n"
 252         where header = takeWhile (\c -> c/='{' && c/='=') arg
 253     _ | conditional key -> "#"++key++" "++arg++"\n"
 254     _ -> ""
 255
 256 outTokenC :: (String, String) -> String
 257 outTokenC (key, arg) = case key of
 258     "def" -> case arg of
 259         's':'t':'r':'u':'c':'t':' ':_ -> ""
 260         't':'y':'p':'e':'d':'e':'f':' ':_ -> ""
 261         'i':'n':'l':'i':'n':'e':' ':_ ->
 262             "#ifndef __GNUC__\n\
 263             \extern\n\
 264             \#endif\n"++
 265             header++
 266             "\n#ifndef __GNUC__\n\
 267             \;\n\
 268             \#else\n"++
 269             body++
 270             "\n#endif\n"
 271         _ -> arg++"\n"
 272         where (header, body) = span (\c -> c/='{' && c/='=') arg
 273     _ | conditional key -> "#"++key++" "++arg++"\n"
 274     _ -> ""
 275
 276 conditional :: String -> Bool
 277 conditional "if"     = True
 278 conditional "ifdef"  = True
 279 conditional "ifndef" = True
 280 conditional "elif"   = True
 281 conditional "else"   = True
 282 conditional "endif"  = True
 283 conditional _        = False
 284
 285 showCString :: String -> String
 286 showCString = concatMap showCChar
 287     where
 288     showCChar '\"' = "\\\""
 289     showCChar '\'' = "\\\'"
 290     showCChar '?'  = "\\?"
 291     showCChar '\\' = "\\\\"
 292     showCChar c | c >= ' ' && c <= '~' = [c]
 293     showCChar '\a' = "\\a"
 294     showCChar '\b' = "\\b"
 295     showCChar '\f' = "\\f"
 296     showCChar '\n' = "\\n\"\n           \""
 297     showCChar '\r' = "\\r"
 298     showCChar '\t' = "\\t"
 299     showCChar '\v' = "\\v"
 300     showCChar c    = ['\\',
 301                       intToDigit (ord c `quot` 64),
 302                       intToDigit (ord c `quot` 8 `mod` 8),
 303                       intToDigit (ord c          `mod` 8)]