wxdirect-0.90.1.0: src/CompileSTC.hs
-----------------------------------------------------------------------------------------
{-| Module : CompileSTC
Copyright : (c) Haste Developer Team 2004, 2005
License : BSD-style
Maintainer : wxhaskell-devel@lists.sourceforge.net
Stability : provisional
Portability : portable
-}
-----------------------------------------------------------------------------------------
module CompileSTC ( compileSTC ) where
import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language
import Data.List
import Control.Monad
import Types
import IOExtra
compileSTC :: Bool -- ^ Verbose
-> FilePath -- ^ Outputdir
-> [FilePath] -- ^ Input files (stc.h)
-> IO ()
compileSTC verbose outputDir inputs = do
dfs <- mapM parseH inputs
let (_ds,fs) = unzip dfs
-- d = concat ds --currently unused
f = concat fs
h_target = outputDir ++ "include/stc_gen.h"
cpp_target = outputDir ++ "src/stc_gen.cpp"
putStrLn $ "generating: " ++ h_target
writeFileLazy h_target $ (glue "\n\n" $ map headerfunc f) ++ "\n"
putStrLn $ "generating: " ++ cpp_target
writeFileLazy cpp_target $ (glue "\n" $ map cppfunc f) ++ "\n"
when verbose $
putStrLn $ "Wrote type macros and c wrappers for " ++ show (length f) ++ " functions."
type Function = (String, String, [(String, String)])
parseH :: FilePath -> IO ([Def], [Function])
parseH fname = do putStrLn ("parsing: " ++ fname)
input <- liftM lines $ readFile fname
let (defs, cpp) = partitionDefines $ input
case parse plines fname (unlines cpp) of
Left err -> print err >> return ([],[])
Right funcs -> return (defs,filter convertable funcs)
-- returns a list of definitions, see Types.Def
-- and a new list of lines without #define's
partitionDefines :: [String] -> ([Def], [String])
partitionDefines lns = (defs, cpp)
where (rdefs, cpp) = partition ("#define wxSTC_" `isPrefixOf`) lns
defs = map (toDef . (drop $ length "#define ")) rdefs
toDef x = let (name,value) = break (==' ') x
in Def name (read value) DefInt
plines :: Parser [Function]
plines = whiteSpace >> many1 pfunc
pfunc :: Parser Function
pfunc = do ret <- identifier
stars <- option "" $ symbol "*"
func <- identifier
args <- parens $ commaSep $ arg
_ <- symbol ";"
return (ret ++ stars,func,args)
where arg = do _ <- option "" $ try $ symbol "const"
t <- identifier
stars <- option "" $ symbol "*"
_ <- option "" $ symbol "&"
name <- identifier
return (t ++ stars, name)
{-----------------------------------------------------------------------------------------
The lexer
-----------------------------------------------------------------------------------------}
lexer :: P.TokenParser ()
lexer
= P.makeTokenParser $ javaStyle
whiteSpace :: Parser ()
whiteSpace = P.whiteSpace lexer
-- lexeme = P.lexeme lexer
symbol :: String -> Parser String
symbol = P.symbol lexer
parens :: Parser a -> Parser a
parens = P.parens lexer
-- semi :: Parser String
-- semi = P.semi lexer
-- comma = P.comma lexer
commaSep :: Parser a -> Parser [a]
commaSep = P.commaSep lexer
identifier :: Parser String
identifier = P.identifier lexer
-- reserved :: String -> Parser ()
-- reserved = P.reserved lexer
{-----------------------------------------------------------------------------------------
code gen
-----------------------------------------------------------------------------------------}
convertable :: Function -> Bool
convertable (t,_f,_a) = elem t ["int", "bool", "void"]
glue :: String -> [String] -> String
glue str strs = concat $ intersperse str strs
-- CPP function generator (Creates functions that can be exported as C functions)
cppfunc :: Function -> String
cppfunc x = macro x ++ arguments x ++ "\n" ++ body x
macro :: Function -> String
macro (ret, func, _args) = "EWXWEXPORT(" ++ ret ++ ", wxStyledTextCtrl_" ++ func ++ ")"
arguments :: Function -> String
arguments (_ret, _func, args) = "(" ++ glue ", " params ++ ")"
where
params = "void* _obj" : rest
rest = map transType args
transType ("int", n) = "int " ++ n
transType ("bool", n) = "bool " ++ n
transType ("void", n) = "void " ++ n
-- transType ("wxString", n) = "char* " ++ n
transType ("wxString", n) = "wxChar* " ++ n
transType ("wxPoint", n) = glue ", " ["int " ++ n ++ p | p <- ["_x","_y"]]
transType ("wxColour", n) = glue ", " ["int " ++ n ++ c | c <- ["_r","_g","_b"]]
transType (_, n) = "void* " ++ n
body :: Function -> String
body (ret, func, args) = "{\n" ++ "#ifdef wxUSE_STC\n "
++ maybeReturn ++ " ((wxStyledTextCtrl*) _obj)->"
++ func ++ "(" ++ glue ", " params ++ ");\n"
++ maybeElse ++ "#endif\n}"
where
maybeReturn = if ret == "void" then "" else "return"
maybeElse = if ret == "void" then "" else "#else\n return NULL;\n"
params = map transParam args
transParam ("int", n) = n
transParam ("bool", n) = n
transParam ("void", n) = n
transParam ("wxString", n) = n
transParam ("wxPoint", n) = "wxPoint(" ++ n ++ "_x," ++ n ++ "_y)"
transParam ("wxColour", n) = "wxColour(" ++ n ++ "_r," ++ n ++ "_g," ++ n ++ "_b)"
transParam ("wxSTCDoc*", n) = n
transParam (t, n) = "*(" ++ t ++ "*) " ++ n
-- Generator for functions signatures with type macros
headerfunc :: Function -> String
headerfunc (ret, func, args) = returnType ret ++ " wxStyledTextCtrl_" ++ func
++ "(" ++ glue ", " params ++ ");"
where
returnType "bool" = "TBool"
returnType "int" = "int"
returnType "void" = "void"
returnType _ = error "wtf?"
params = "TSelf(wxStyledTextCtrl) _obj" : rest
rest = map transType args
transType ("bool", n) = "TBool " ++ n
transType ("int", n) = "int " ++ n
transType ("int*", n) = "int* " ++ n
transType ("void", n) = "void " ++ n
transType ("char*", n) = "TString " ++ n
-- transType ("wchar_t*", n) = "TString " ++ n
-- transType ("wxChar*", n) = "TString " ++ n
transType ("wxString", n) = "TString " ++ n
transType ("wxPoint", n) = "TPoint(" ++ n ++ "_x," ++ n ++ "_y)"
transType ("wxColour", n) = "TColorRGB(" ++ n ++ "_r," ++ n ++ "_g," ++ n ++ "_b)"
transType (t, n) | "*" `isSuffixOf` t = "TClass(" ++ init t ++ ") " ++ n
| otherwise = "TClass(" ++ t ++ ") " ++ n