")
identifier
parseFunc :: Parser String
parseFunc = do
manyTill anyChar (try start)
f <- manyTill anyChar $ char ';'
return $ clean f
where
start = string ""
clean [] = []
clean (x:xs)
| x=='<' = clean' xs
| x=='\n' = clean xs
| otherwise = x:clean xs
clean' [] = []
clean' (x:xs)
| x=='>' = clean xs
| otherwise = clean' xs
parseSignature :: Parser (String, String, [String])
parseSignature = do
many space
ret <- identifier
many space
fun <- identifier
many space
string "("
many space
p <- many (try param)
return (fun, ret, p)
where
space_comma = do
many space
char ',' <|> char ')'
param = do
many space
c <- manyTill anyChar $ try space_comma
when (length c==0) $ fail "not long enough"
return c
type Interface = (String, String, [(String,Type,[(String,Type)])])
readInterface :: String -> (String,String,Interface->Interface) -> IO Interface
readInterface path (name,base,f) = do
put $ name ++ " from " ++ path ++ "/" ++ name ++ ".htm"
values <- readFile (path++"/"++name++".htm") >>= run parseInterface >>= mapM getFunc
return $ f (name, base, values)
where
getFunc fun = do
put $ name ++ " from " ++ path ++ "/" ++ name ++ "__" ++ fun ++ ".htm"
s <- readFile (path++"/"++name++"__"++fun++".htm") >>= run parseFunc
put s
(n, t, p) <- run parseSignature s
put t
t' <- run parseRetType t
p' <- mapM (\x -> put x >> run parseType x) p
return (n, t', concat p')
---------------------------------------------------------------------------
-- structures
parseStruct :: String -> Parser [String]
parseStruct name = do
manyTill anyChar (try start)
manyTill field $ try (many space >> char '}')
where
start = string $ "typedef struct " ++ name ++ " {"
field = do
many space
option ' ' $ char '\n'
many space
manyTill anyChar $ try (many space >> char ';')
readStruct :: String -> String -> IO (String, [(String,Type)])
readStruct path name = do
put $ name ++ " from " ++ path ++ "/" ++ name ++ ".htm"
fields <- readFile (path++"/"++name++".htm") >>= run (parseStruct name)
fields' <- mapM (\x -> put x >> run parseType x) fields
return (name, concat fields')
---------------------------------------------------------------------------
-- Printing
c_decl :: [(String, a)] -> String
c_decl = concatMap p
where
p (x,_) = "typedef struct " ++ x ++ " " ++ x ++ ";\n"
c_decl3 :: [(String, a, b)] -> String
c_decl3 = concatMap p
where
p (x,_,_) = "typedef struct " ++ x ++ " " ++ x ++ ";\n"
c_type :: String -> Type -> String
c_type name t = arr t
where
arr (Array s t) = arr t ++ "[" ++ s ++ "]"
arr t = ptr t ++ " " ++ name
ptr (Pointer t) = ptr t ++ "*"
ptr (Base s)
| s=="D3DLight9" = "D3DLIGHT9"
| s=="LPD3DXFileSaveData" = "LPD3DXFILESAVEDATA"
| s=="LpD3DDeviceXPMESH" = "LPD3DXPMESH"
| otherwise = s
c_fun :: (String, Type, [(String,Type)]) -> String
c_fun (n,ret,par) =
c_type n ret ++ "(" ++
(concat $ intersperse "," $ map (uncurry c_type) par)
++ ")"
c_def_i :: (String, String, [(String,Type,[(String,Type)])]) -> String
c_def_i (n, b, f) = concat[
"struct vtbl",n," {\n",
"struct vtbl",b," base;\n",
concat $ intersperse ";\n" $ map fun f,
";\n};\n",
"struct ", n, "{ struct vtbl",n," *vtbl; };\n",
concatMap fun2 f,
"\n"]
where
fun :: (String, Type, [(String,Type)]) -> String
fun (n, t, p) = c_fun ("(__stdcall *"++n++")", t, p)
fun2 (n',t,p) = concat $
[c_type (n++"_"++n') t, "("]
++ (intersperse "," $ map (uncurry c_type) (("object",Pointer (Base n)):p))
++ [") { return object->vtbl->", n', "(" ]
++ (intersperse "," $ map fst p)
++ ["); }\n"]
c_def_if :: (String, String, [(String, Type, [(String,Type)])]) -> String
c_def_if (n,_,f) = concatMap fun f
where
{-
fun (n',t,p) = concat $
[c_type ("c_"++n++"_"++n') t, "("]
++ (intersperse "," $ map (uncurry c_type) (("object", Pointer $ Base n):p))
++ [") { return "]
++ [n,"_",n',"("]
++ (intersperse "," $ ("object": map fst p))
++ ["); }\n"]
-}
fun (n',t,p) = concat $
[c_type ("c_"++n++"_"++n') t, "("]
++ (intersperse "," $ map (uncurry c_type) (("object", Pointer $ Base n):p))
++ [") { return object->lpVtbl->", n', "("]
++ (intersperse "," $ ("object":map fst p))
++ ["); }\n"]
c_def_e :: (String, [(String,String)]) -> String
c_def_e (e, v) = concat [
"typedef enum ", e, " ", e, ";\n",
"enum ", e, " {\n",
concat $ intersperse ",\n" $ map val v,
"\n};\n"]
where
val (n,v) = n ++ " = " ++ v
c_def_e2 :: (String, a) -> String
c_def_e2 (e,_) = "typedef DWORD " ++ e ++ ";\n"
h_type :: Type -> String
h_type t = case t of
Pointer (Base s) -> "Ptr " ++ trans s
Array _ (Base s) -> "Ptr " ++ trans s
IO_ (Base s) -> "IO " ++ trans s
Pointer t -> "Ptr (" ++ h_type t ++ ")"
Array _ t -> "Ptr (" ++ h_type t ++ ")"
IO_ t -> "IO (" ++ h_type t ++ ")"
Base s -> trans s
where
trans s
| s=="void" = "()"
| s=="VOID" = "()"
| s=="float" = "Float"
| s=="char" = "Char"
| s=="int" = "Int"
| s=="D3DLight9" = "D3DLIGHT9"
| s=="DOUBLE" = "Double"
| s=="LpD3DDeviceXPMESH" = "(Ptr ID3DXPMesh)"
-- | isPrefixOf "LP" s = "(Ptr " ++ (trans $ drop 2 s) ++ ")"
| otherwise = s
h_fun :: Type -> [Type] -> String
h_fun ret p = concat $ intersperse " -> " $ map h_type (p ++ [ret])
h_def_i :: (String, String, [(String, Type, [(String, Type)])]) -> String
h_def_i (n,_,f) = concat $ [
"data ", n, " = ", n, " deriving (Show)\n"]
++ (intersperse "\n" $ map fun f)
++ ["\n"]
++ pointer
++ ["\n\n"]
where
pointer = [
"type LP", n, " = Ptr ", n, "\n",
"type LP", map toUpper (tail n), " = Ptr ", n, "\n"]
fun (n', t, p) =
"foreign import ccall unsafe \"fake.h c_" ++n++"_"++n'++"\"\n"
++" c_"++n++"_"++n'++"::"++ h_fun (IO_ t) ((Pointer (Base n)):(map snd p))
h_def_s :: (String,[(String,Type)]) -> String
h_def_s (s,v) = concat [
"data ", s, " = ", s, "{ ",
concat $ intersperse "," $ map constr v,
" } deriving (Show,Eq,Ord)\n",
pointer,
storable]
where
typ :: Type -> String
typ (Base t) = "!" ++ h_type (Base t)
typ t = "!(" ++ h_type t ++ ")"
constr (n,t) = let
(x:xs) = (s++"_"++n)
n' = (toLower x):xs
in n' ++ " :: " ++ typ t
pointer = concat [
"type LP", s, " = Ptr ", s, "\n"]
storable = concat$[
"instance Storable ", s, " where\n",
" sizeOf _ = "] ++ (intersperse "+" $ map size v) ++ ["\n",
" alignment = const 1\n",
" poke b (",s," "]++ (intersperse " " $ params) ++[")\n",
" = return b >>= pokeHelp "] ++ (intersperse " >>= pokeHelp " params)
++ [" >> return()\n",
" peek b = do\n"] ++ (init $ concatMap peek params)
++ [" return (",s, " "] ++ (intersperse " " params) ++ [")\n\n"]
size (_,t) = "(sizeOf (undefined::("++h_type t++")))"
param p = "p" ++ show p
params = map param [1..length v]
peek p = [" " ++ p ++ " <- peekByteOff b 0\n"," b <- return $ plusPtr b (sizeOf " ++ p ++ ")\n"]
h_def_e :: [(String,String)] -> (String, [(String, String)]) -> String
h_def_e types (e,v) = "type " ++ e ++ " = " ++ t ++ "\n" ++ (concatMap print v) ++ "\n"
where
print (n:n',v) = ((toLower n):n') ++ "::"++e++"\n" ++ ((toLower n):n') ++ "=" ++ v ++ "\n"
t = case lookup e types of
Just x -> x
Nothing -> "DWORD"