2 * Copyright (C) 2009-2010 Red Hat Inc.
4 * This program is free software; you can redistribute it and/or modify
5 * it under the terms of the GNU General Public License as published by
6 * the Free Software Foundation; either version 2 of the License, or
7 * (at your option) any later version.
9 * This program is distributed in the hope that it will be useful,
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 * GNU General Public License for more details.
14 * You should have received a copy of the GNU General Public License
15 * along with this program; if not, write to the Free Software
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
19 (* Please read generator/README first. *)
26 open Generator_docstrings
27 open Generator_optgroups
28 open Generator_actions
29 open Generator_structs
31 let rec generate_haskell_hs () =
32 generate_header HaskellStyle LGPLv2plus;
34 (* XXX We only know how to generate partial FFI for Haskell
35 * at the moment. Please help out!
37 let can_generate style =
44 | RConstOptString _, _
50 | RBufferOut _, _ -> false in
53 {-# INCLUDE <guestfs.h> #-}
54 {-# LANGUAGE ForeignFunctionInterface #-}
59 (* List out the names of the actions we want to export. *)
61 fun (name, style, _, _, _, _, _) ->
62 if can_generate style then pr ",\n %s" name
68 -- Unfortunately some symbols duplicate ones already present
69 -- in Prelude. We don't know which, so we hard-code a list
71 import Prelude hiding (truncate)
75 import Foreign.C.Types
77 import Control.Exception
80 data GuestfsS = GuestfsS -- represents the opaque C struct
81 type GuestfsP = Ptr GuestfsS -- guestfs_h *
82 type GuestfsH = ForeignPtr GuestfsS -- guestfs_h * with attached finalizer
84 -- XXX define properly later XXX
88 data IntBool = IntBool
90 data StatVFS = StatVFS
91 data Hashtable = Hashtable
93 foreign import ccall unsafe \"guestfs_create\" c_create
95 foreign import ccall unsafe \"&guestfs_close\" c_close
96 :: FunPtr (GuestfsP -> IO ())
97 foreign import ccall unsafe \"guestfs_set_error_handler\" c_set_error_handler
98 :: GuestfsP -> Ptr CInt -> Ptr CInt -> IO ()
100 create :: IO GuestfsH
103 c_set_error_handler p nullPtr nullPtr
104 h <- newForeignPtr c_close p
107 foreign import ccall unsafe \"guestfs_last_error\" c_last_error
108 :: GuestfsP -> IO CString
110 -- last_error :: GuestfsH -> IO (Maybe String)
112 -- str <- withForeignPtr h (\\p -> c_last_error p)
113 -- maybePeek peekCString str
115 last_error :: GuestfsH -> IO (String)
117 str <- withForeignPtr h (\\p -> c_last_error p)
119 then return \"no error\"
124 (* Generate wrappers for each foreign function. *)
126 fun (name, style, _, _, _, _, _) ->
127 if can_generate style then (
128 pr "foreign import ccall unsafe \"guestfs_%s\" c_%s\n" name name;
130 generate_haskell_prototype ~handle:"GuestfsP" style;
134 generate_haskell_prototype ~handle:"GuestfsH" ~hs:true style;
136 pr "%s %s = do\n" name
137 (String.concat " " ("h" :: List.map name_of_argt (snd style)));
139 (* Convert pointer arguments using with* functions. *)
144 | Pathname n | Device n | Dev_or_Path n | String n | Key n ->
145 pr "withCString %s $ \\%s -> " n n
147 pr "withCStringLen %s $ \\(%s, %s_size) -> " n n n
148 | OptString n -> pr "maybeWith withCString %s $ \\%s -> " n n
149 | StringList n | DeviceList n -> pr "withMany withCString %s $ \\%s -> withArray0 nullPtr %s $ \\%s -> " n n n n
150 | Bool _ | Int _ | Int64 _ -> ()
152 (* Convert integer arguments. *)
156 | Bool n -> sprintf "(fromBool %s)" n
157 | Int n -> sprintf "(fromIntegral %s)" n
158 | Int64 n -> sprintf "(fromIntegral %s)" n
159 | FileIn n | FileOut n
160 | Pathname n | Device n | Dev_or_Path n
161 | String n | OptString n
162 | StringList n | DeviceList n
164 | BufferIn n -> sprintf "%s (fromIntegral %s_size)" n n
166 pr "withForeignPtr h (\\p -> c_%s %s)\n" name
167 (String.concat " " ("p" :: args));
168 (match fst style with
169 | RErr | RInt _ | RInt64 _ | RBool _ ->
170 pr " if (r == -1)\n";
172 pr " err <- last_error h\n";
174 | RConstString _ | RConstOptString _ | RString _
175 | RStringList _ | RStruct _
176 | RStructList _ | RHashtable _ | RBufferOut _ ->
177 pr " if (r == nullPtr)\n";
179 pr " err <- last_error h\n";
182 (match fst style with
184 pr " else return ()\n"
186 pr " else return (fromIntegral r)\n"
188 pr " else return (fromIntegral r)\n"
190 pr " else return (toBool r)\n"
199 pr " else return ()\n" (* XXXXXXXXXXXXXXXXXXXX *)
205 and generate_haskell_prototype ~handle ?(hs = false) style =
207 let string = if hs then "String" else "CString" in
208 let int = if hs then "Int" else "CInt" in
209 let bool = if hs then "Bool" else "CInt" in
210 let int64 = if hs then "Integer" else "Int64" in
214 | Pathname _ | Device _ | Dev_or_Path _ | String _ | Key _ ->
217 if hs then pr "String"
218 else pr "CString -> CInt"
219 | OptString _ -> if hs then pr "Maybe String" else pr "CString"
220 | StringList _ | DeviceList _ -> if hs then pr "[String]" else pr "Ptr CString"
221 | Bool _ -> pr "%s" bool
222 | Int _ -> pr "%s" int
223 | Int64 _ -> pr "%s" int
224 | FileIn _ -> pr "%s" string
225 | FileOut _ -> pr "%s" string
230 (match fst style with
231 | RErr -> if not hs then pr "CInt"
232 | RInt _ -> pr "%s" int
233 | RInt64 _ -> pr "%s" int64
234 | RBool _ -> pr "%s" bool
235 | RConstString _ -> pr "%s" string
236 | RConstOptString _ -> pr "Maybe %s" string
237 | RString _ -> pr "%s" string
238 | RStringList _ -> pr "[%s]" string
239 | RStruct (_, typ) ->
240 let name = java_name_of_struct typ in
242 | RStructList (_, typ) ->
243 let name = java_name_of_struct typ in
245 | RHashtable _ -> pr "Hashtable"
246 | RBufferOut _ -> pr "%s" string