configure: Fix info about virt-resize when OCaml bindings are disabled.
[libguestfs.git] / generator / generator_haskell.ml
1 (* libguestfs
2  * Copyright (C) 2009-2010 Red Hat Inc.
3  *
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.
8  *
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.
13  *
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
17  *)
18
19 (* Please read generator/README first. *)
20
21 open Printf
22
23 open Generator_types
24 open Generator_utils
25 open Generator_pr
26 open Generator_docstrings
27 open Generator_optgroups
28 open Generator_actions
29 open Generator_structs
30
31 let rec generate_haskell_hs () =
32   generate_header HaskellStyle LGPLv2plus;
33
34   (* XXX We only know how to generate partial FFI for Haskell
35    * at the moment.  Please help out!
36    *)
37   let can_generate style =
38     match style with
39     | _, _, (_::_) -> false (* no optional args yet *)
40     | RErr, _, []
41     | RInt _, _, []
42     | RInt64 _, _, [] -> true
43     | RBool _, _, []
44     | RConstString _, _, []
45     | RConstOptString _, _, []
46     | RString _, _, []
47     | RStringList _, _, []
48     | RStruct _, _, []
49     | RStructList _, _, []
50     | RHashtable _, _, []
51     | RBufferOut _, _, [] -> false in
52
53   pr "\
54 {-# INCLUDE <guestfs.h> #-}
55 {-# LANGUAGE ForeignFunctionInterface #-}
56
57 module Guestfs (
58   create";
59
60   (* List out the names of the actions we want to export. *)
61   List.iter (
62     fun (name, style, _, _, _, _, _) ->
63       if can_generate style then pr ",\n  %s" name
64   ) all_functions;
65
66   pr "
67   ) where
68
69 -- Unfortunately some symbols duplicate ones already present
70 -- in Prelude.  We don't know which, so we hard-code a list
71 -- here.
72 import Prelude hiding (truncate)
73
74 import Foreign
75 import Foreign.C
76 import Foreign.C.Types
77 import System.IO
78 import Control.Exception
79 import Data.Typeable
80
81 data GuestfsS = GuestfsS            -- represents the opaque C struct
82 type GuestfsP = Ptr GuestfsS        -- guestfs_h *
83 type GuestfsH = ForeignPtr GuestfsS -- guestfs_h * with attached finalizer
84
85 -- XXX define properly later XXX
86 data PV = PV
87 data VG = VG
88 data LV = LV
89 data IntBool = IntBool
90 data Stat = Stat
91 data StatVFS = StatVFS
92 data Hashtable = Hashtable
93
94 foreign import ccall unsafe \"guestfs_create\" c_create
95   :: IO GuestfsP
96 foreign import ccall unsafe \"&guestfs_close\" c_close
97   :: FunPtr (GuestfsP -> IO ())
98 foreign import ccall unsafe \"guestfs_set_error_handler\" c_set_error_handler
99   :: GuestfsP -> Ptr CInt -> Ptr CInt -> IO ()
100
101 create :: IO GuestfsH
102 create = do
103   p <- c_create
104   c_set_error_handler p nullPtr nullPtr
105   h <- newForeignPtr c_close p
106   return h
107
108 foreign import ccall unsafe \"guestfs_last_error\" c_last_error
109   :: GuestfsP -> IO CString
110
111 -- last_error :: GuestfsH -> IO (Maybe String)
112 -- last_error h = do
113 --   str <- withForeignPtr h (\\p -> c_last_error p)
114 --   maybePeek peekCString str
115
116 last_error :: GuestfsH -> IO (String)
117 last_error h = do
118   str <- withForeignPtr h (\\p -> c_last_error p)
119   if (str == nullPtr)
120     then return \"no error\"
121     else peekCString str
122
123 ";
124
125   (* Generate wrappers for each foreign function. *)
126   List.iter (
127     fun (name, (ret, args, optargs as style), _, _, _, _, _) ->
128       if can_generate style then (
129         pr "foreign import ccall unsafe \"guestfs_%s\" c_%s\n" name name;
130         pr "  :: ";
131         generate_haskell_prototype ~handle:"GuestfsP" style;
132         pr "\n";
133         pr "\n";
134         pr "%s :: " name;
135         generate_haskell_prototype ~handle:"GuestfsH" ~hs:true style;
136         pr "\n";
137         pr "%s %s = do\n" name
138           (String.concat " " ("h" :: List.map name_of_argt args));
139         pr "  r <- ";
140         (* Convert pointer arguments using with* functions. *)
141         List.iter (
142           function
143           | FileIn n
144           | FileOut n
145           | Pathname n | Device n | Dev_or_Path n | String n | Key n ->
146               pr "withCString %s $ \\%s -> " n n
147           | BufferIn n ->
148               pr "withCStringLen %s $ \\(%s, %s_size) -> " n n n
149           | OptString n -> pr "maybeWith withCString %s $ \\%s -> " n n
150           | StringList n | DeviceList n -> pr "withMany withCString %s $ \\%s -> withArray0 nullPtr %s $ \\%s -> " n n n n
151           | Bool _ | Int _ | Int64 _ | Pointer _ -> ()
152         ) args;
153         (* Convert integer arguments. *)
154         let args =
155           List.map (
156             function
157             | Bool n -> sprintf "(fromBool %s)" n
158             | Int n -> sprintf "(fromIntegral %s)" n
159             | Int64 n | Pointer (_, n) -> sprintf "(fromIntegral %s)" n
160             | FileIn n | FileOut n
161             | Pathname n | Device n | Dev_or_Path n
162             | String n | OptString n
163             | StringList n | DeviceList n
164             | Key n -> n
165             | BufferIn n -> sprintf "%s (fromIntegral %s_size)" n n
166           ) args in
167         pr "withForeignPtr h (\\p -> c_%s %s)\n" name
168           (String.concat " " ("p" :: args));
169         (match ret with
170          | RErr | RInt _ | RInt64 _ | RBool _ ->
171              pr "  if (r == -1)\n";
172              pr "    then do\n";
173              pr "      err <- last_error h\n";
174              pr "      fail err\n";
175          | RConstString _ | RConstOptString _ | RString _
176          | RStringList _ | RStruct _
177          | RStructList _ | RHashtable _ | RBufferOut _ ->
178              pr "  if (r == nullPtr)\n";
179              pr "    then do\n";
180              pr "      err <- last_error h\n";
181              pr "      fail err\n";
182         );
183         (match ret with
184          | RErr ->
185              pr "    else return ()\n"
186          | RInt _ ->
187              pr "    else return (fromIntegral r)\n"
188          | RInt64 _ ->
189              pr "    else return (fromIntegral r)\n"
190          | RBool _ ->
191              pr "    else return (toBool r)\n"
192          | RConstString _
193          | RConstOptString _
194          | RString _
195          | RStringList _
196          | RStruct _
197          | RStructList _
198          | RHashtable _
199          | RBufferOut _ ->
200              pr "    else return ()\n" (* XXXXXXXXXXXXXXXXXXXX *)
201         );
202         pr "\n";
203       )
204   ) all_functions
205
206 and generate_haskell_prototype ~handle ?(hs = false) (ret, args, optargs) =
207   pr "%s -> " handle;
208   let string = if hs then "String" else "CString" in
209   let int = if hs then "Int" else "CInt" in
210   let bool = if hs then "Bool" else "CInt" in
211   let int64 = if hs then "Integer" else "Int64" in
212   List.iter (
213     fun arg ->
214       (match arg with
215        | Pathname _ | Device _ | Dev_or_Path _ | String _ | Key _ ->
216            pr "%s" string
217        | BufferIn _ ->
218            if hs then pr "String"
219            else pr "CString -> CInt"
220        | OptString _ -> if hs then pr "Maybe String" else pr "CString"
221        | StringList _ | DeviceList _ -> if hs then pr "[String]" else pr "Ptr CString"
222        | Bool _ -> pr "%s" bool
223        | Int _ -> pr "%s" int
224        | Int64 _ -> pr "%s" int
225        | Pointer _ -> pr "%s" int
226        | FileIn _ -> pr "%s" string
227        | FileOut _ -> pr "%s" string
228       );
229       pr " -> ";
230   ) args;
231   pr "IO (";
232   (match ret with
233    | RErr -> if not hs then pr "CInt"
234    | RInt _ -> pr "%s" int
235    | RInt64 _ -> pr "%s" int64
236    | RBool _ -> pr "%s" bool
237    | RConstString _ -> pr "%s" string
238    | RConstOptString _ -> pr "Maybe %s" string
239    | RString _ -> pr "%s" string
240    | RStringList _ -> pr "[%s]" string
241    | RStruct (_, typ) ->
242        let name = java_name_of_struct typ in
243        pr "%s" name
244    | RStructList (_, typ) ->
245        let name = java_name_of_struct typ in
246        pr "[%s]" name
247    | RHashtable _ -> pr "Hashtable"
248    | RBufferOut _ -> pr "%s" string
249   );
250   pr ")"