Partial Haskell bindings.
authorRichard Jones <rjones@redhat.com>
Sat, 9 May 2009 16:19:24 +0000 (17:19 +0100)
committerRichard Jones <rjones@redhat.com>
Sun, 10 May 2009 12:52:49 +0000 (13:52 +0100)
12 files changed:
.gitignore
HACKING
Makefile.am
README
configure.ac
guestfs.pod
haskell/Guestfs.hs [new file with mode: 0644]
haskell/Guestfs005Load.hs [new file with mode: 0644]
haskell/Guestfs010Launch.hs [new file with mode: 0644]
haskell/Guestfs050LVCreate.hs [new file with mode: 0644]
haskell/Makefile.am [new file with mode: 0644]
src/generator.ml

index 14cada4..c9b27a3 100644 (file)
@@ -14,6 +14,7 @@
 *.so
 *.class
 *.jar
 *.so
 *.class
 *.jar
+*.hi
 ChangeLog
 Makefile.in
 Makefile
 ChangeLog
 Makefile.in
 Makefile
@@ -37,6 +38,9 @@ examples/to-xml
 fish/guestfish
 guestfish.1
 guestfs.3
 fish/guestfish
 guestfish.1
 guestfs.3
+haskell/Guestfs005Load
+haskell/Guestfs010Launch
+haskell/Guestfs050LVCreate
 html/guestfish.1.html
 html/guestfs.3.html
 html/recipes.html
 html/guestfish.1.html
 html/guestfs.3.html
 html/recipes.html
diff --git a/HACKING b/HACKING
index 7d235bc..8ad6e9a 100644 (file)
--- a/HACKING
+++ b/HACKING
@@ -43,6 +43,9 @@ examples/
 fish/
        Guestfish (the command-line program / shell)
 
 fish/
        Guestfish (the command-line program / shell)
 
+haskell/
+       Haskell bindings.
+
 images/
        Some guest images to test against.  These are gzipped to save
        space.  You have to unzip them before use.
 images/
        Some guest images to test against.  These are gzipped to save
        space.  You have to unzip them before use.
index 8f81a07..80ea875 100644 (file)
@@ -34,6 +34,9 @@ endif
 if HAVE_JAVA
 SUBDIRS += java
 endif
 if HAVE_JAVA
 SUBDIRS += java
 endif
+if HAVE_HASKELL
+SUBDIRS += haskell
+endif
 if HAVE_INSPECTOR
 SUBDIRS += inspector
 endif
 if HAVE_INSPECTOR
 SUBDIRS += inspector
 endif
diff --git a/README b/README
index 9efcb9b..abf058e 100644 (file)
--- a/README
+++ b/README
@@ -16,8 +16,8 @@ LVs, what filesystem is in each LV, etc.).  It can also run commands
 in the context of the guest.  Also you can access filesystems over FTP.
 
 Libguestfs is a library that can be linked with C and C++ management
 in the context of the guest.  Also you can access filesystems over FTP.
 
 Libguestfs is a library that can be linked with C and C++ management
-programs (or management programs written in OCaml, Perl, Python, Ruby or Java).
-You can also use it from shell scripts or the command line.
+programs (or management programs written in OCaml, Perl, Python, Ruby, Java
+or Haskell).  You can also use it from shell scripts or the command line.
 
 Libguestfs was written by Richard W.M. Jones (rjones@redhat.com).
 For discussion please use the fedora-virt mailing list:
 
 Libguestfs was written by Richard W.M. Jones (rjones@redhat.com).
 For discussion please use the fedora-virt mailing list:
@@ -56,6 +56,8 @@ also to build the OCaml bindings
 - (Optional) Java, JNI, jpackage-utils if you want to build the java
 bindings
 
 - (Optional) Java, JNI, jpackage-utils if you want to build the java
 bindings
 
+- (Optional) GHC if you want to build the Haskell bindings
+
 Running ./configure will check you have all the requirements installed
 on your machine.
 
 Running ./configure will check you have all the requirements installed
 on your machine.
 
index 4c20e12..67d626e 100644 (file)
@@ -394,6 +394,12 @@ AC_SUBST(JNI_VERSION_INFO)
 
 AM_CONDITIONAL([HAVE_JAVA],[test -n "$JAVAC"])
 
 
 AM_CONDITIONAL([HAVE_JAVA],[test -n "$JAVAC"])
 
+dnl Check for Haskell (GHC).
+AC_CHECK_PROG([GHC],[ghc],[ghc],[no])
+
+AM_CONDITIONAL([HAVE_HASKELL],
+    [test "x$GHC" != "xno"])
+
 dnl Check for Perl modules needed by the inspector.
 missing_perl_modules=no
 for pm in Pod::Usage Getopt::Long Sys::Virt Data::Dumper; do
 dnl Check for Perl modules needed by the inspector.
 missing_perl_modules=no
 for pm in Pod::Usage Getopt::Long Sys::Virt Data::Dumper; do
@@ -424,6 +430,7 @@ AC_CONFIG_FILES([Makefile src/Makefile fish/Makefile examples/Makefile
                 python/Makefile
                 ruby/Makefile ruby/Rakefile
                 java/Makefile
                 python/Makefile
                 ruby/Makefile ruby/Rakefile
                 java/Makefile
+                haskell/Makefile
                 inspector/Makefile
                 make-initramfs.sh update-initramfs.sh
                 libguestfs.spec libguestfs.pc
                 inspector/Makefile
                 make-initramfs.sh update-initramfs.sh
                 libguestfs.spec libguestfs.pc
@@ -452,6 +459,8 @@ echo -n "Ruby bindings ....................... "
 if test "x$HAVE_RUBY_TRUE" = "x"; then echo "yes"; else echo "no"; fi
 echo -n "Java bindings ....................... "
 if test "x$HAVE_JAVA_TRUE" = "x"; then echo "yes"; else echo "no"; fi
 if test "x$HAVE_RUBY_TRUE" = "x"; then echo "yes"; else echo "no"; fi
 echo -n "Java bindings ....................... "
 if test "x$HAVE_JAVA_TRUE" = "x"; then echo "yes"; else echo "no"; fi
+echo -n "Haskell bindings .................... "
+if test "x$HAVE_HASKELL" = "x"; then echo "yes"; else echo "no"; fi
 echo -n "virt-inspector ...................... "
 if test "x$HAVE_INSPECTOR" = "x"; then echo "yes"; else echo "no"; fi
 echo
 echo -n "virt-inspector ...................... "
 if test "x$HAVE_INSPECTOR" = "x"; then echo "yes"; else echo "no"; fi
 echo
index 9cef777..06cc2b3 100644 (file)
@@ -37,8 +37,8 @@ LVs, what filesystem is in each LV, etc.).  It can also run commands
 in the context of the guest.  Also you can access filesystems over FTP.
 
 Libguestfs is a library that can be linked with C and C++ management
 in the context of the guest.  Also you can access filesystems over FTP.
 
 Libguestfs is a library that can be linked with C and C++ management
-programs (or management programs written in OCaml, Perl, Python, Ruby or Java).
-You can also use it from shell scripts or the command line.
+programs (or management programs written in OCaml, Perl, Python, Ruby, Java
+or Haskell).  You can also use it from shell scripts or the command line.
 
 You don't need to be root to use libguestfs, although obviously you do
 need enough permissions to access the disk images.
 
 You don't need to be root to use libguestfs, although obviously you do
 need enough permissions to access the disk images.
diff --git a/haskell/Guestfs.hs b/haskell/Guestfs.hs
new file mode 100644 (file)
index 0000000..aedf3b5
--- /dev/null
@@ -0,0 +1,777 @@
+{- libguestfs generated file
+   WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.
+   ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.
+  
+   Copyright (C) 2009 Red Hat Inc.
+  
+   This library is free software; you can redistribute it and/or
+   modify it under the terms of the GNU Lesser General Public
+   License as published by the Free Software Foundation; either
+   version 2 of the License, or (at your option) any later version.
+  
+   This library is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+   Lesser General Public License for more details.
+  
+   You should have received a copy of the GNU Lesser General Public
+   License along with this library; if not, write to the Free Software
+   Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+-}
+
+{-# INCLUDE <guestfs.h> #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Guestfs (
+  create,
+  launch,
+  wait_ready,
+  kill_subprocess,
+  add_drive,
+  add_cdrom,
+  config,
+  set_qemu,
+  set_path,
+  set_busy,
+  set_ready,
+  end_busy,
+  mount,
+  sync,
+  touch,
+  aug_close,
+  aug_set,
+  aug_mv,
+  aug_save,
+  aug_load,
+  rm,
+  rmdir,
+  rm_rf,
+  mkdir,
+  mkdir_p,
+  pvcreate,
+  vgcreate,
+  mkfs,
+  umount,
+  umount_all,
+  lvm_remove_all,
+  blockdev_setro,
+  blockdev_setrw,
+  blockdev_flushbufs,
+  blockdev_rereadpt,
+  upload,
+  download,
+  tar_in,
+  tar_out,
+  tgz_in,
+  tgz_out,
+  mount_ro,
+  mount_options,
+  mount_vfs,
+  lvremove,
+  vgremove,
+  pvremove,
+  set_e2label,
+  set_e2uuid,
+  zero,
+  grub_install,
+  cp,
+  cp_a,
+  mv,
+  ping_daemon
+  ) where
+import Foreign
+import Foreign.C
+import IO
+import Control.Exception
+import Data.Typeable
+
+data GuestfsS = GuestfsS            -- represents the opaque C struct
+type GuestfsP = Ptr GuestfsS        -- guestfs_h *
+type GuestfsH = ForeignPtr GuestfsS -- guestfs_h * with attached finalizer
+
+-- XXX define properly later XXX
+data PV = PV
+data VG = VG
+data LV = LV
+data IntBool = IntBool
+data Stat = Stat
+data StatVFS = StatVFS
+data Hashtable = Hashtable
+
+foreign import ccall unsafe "guestfs_create" c_create
+  :: IO GuestfsP
+foreign import ccall unsafe "&guestfs_close" c_close
+  :: FunPtr (GuestfsP -> IO ())
+foreign import ccall unsafe "guestfs_set_error_handler" c_set_error_handler
+  :: GuestfsP -> Ptr CInt -> Ptr CInt -> IO ()
+
+create :: IO GuestfsH
+create = do
+  p <- c_create
+  c_set_error_handler p nullPtr nullPtr
+  h <- newForeignPtr c_close p
+  return h
+
+foreign import ccall unsafe "guestfs_last_error" c_last_error
+  :: GuestfsP -> IO CString
+
+-- last_error :: GuestfsH -> IO (Maybe String)
+-- last_error h = do
+--   str <- withForeignPtr h (\p -> c_last_error p)
+--   maybePeek peekCString str
+
+last_error :: GuestfsH -> IO (String)
+last_error h = do
+  str <- withForeignPtr h (\p -> c_last_error p)
+  if (str == nullPtr)
+    then return "no error"
+    else peekCString str
+
+foreign import ccall unsafe "guestfs_launch" c_launch
+  :: GuestfsP -> IO (CInt)
+
+launch :: GuestfsH -> IO ()
+launch h = do
+  r <- withForeignPtr h (\p -> c_launch p)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_wait_ready" c_wait_ready
+  :: GuestfsP -> IO (CInt)
+
+wait_ready :: GuestfsH -> IO ()
+wait_ready h = do
+  r <- withForeignPtr h (\p -> c_wait_ready p)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_kill_subprocess" c_kill_subprocess
+  :: GuestfsP -> IO (CInt)
+
+kill_subprocess :: GuestfsH -> IO ()
+kill_subprocess h = do
+  r <- withForeignPtr h (\p -> c_kill_subprocess p)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_add_drive" c_add_drive
+  :: GuestfsP -> CString -> IO (CInt)
+
+add_drive :: GuestfsH -> String -> IO ()
+add_drive h filename = do
+  r <- withCString filename $ \filename -> withForeignPtr h (\p -> c_add_drive p filename)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_add_cdrom" c_add_cdrom
+  :: GuestfsP -> CString -> IO (CInt)
+
+add_cdrom :: GuestfsH -> String -> IO ()
+add_cdrom h filename = do
+  r <- withCString filename $ \filename -> withForeignPtr h (\p -> c_add_cdrom p filename)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_config" c_config
+  :: GuestfsP -> CString -> CString -> IO (CInt)
+
+config :: GuestfsH -> String -> Maybe String -> IO ()
+config h qemuparam qemuvalue = do
+  r <- withCString qemuparam $ \qemuparam -> maybeWith withCString qemuvalue $ \qemuvalue -> withForeignPtr h (\p -> c_config p qemuparam qemuvalue)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_set_qemu" c_set_qemu
+  :: GuestfsP -> CString -> IO (CInt)
+
+set_qemu :: GuestfsH -> String -> IO ()
+set_qemu h qemu = do
+  r <- withCString qemu $ \qemu -> withForeignPtr h (\p -> c_set_qemu p qemu)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_set_path" c_set_path
+  :: GuestfsP -> CString -> IO (CInt)
+
+set_path :: GuestfsH -> String -> IO ()
+set_path h path = do
+  r <- withCString path $ \path -> withForeignPtr h (\p -> c_set_path p path)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_set_busy" c_set_busy
+  :: GuestfsP -> IO (CInt)
+
+set_busy :: GuestfsH -> IO ()
+set_busy h = do
+  r <- withForeignPtr h (\p -> c_set_busy p)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_set_ready" c_set_ready
+  :: GuestfsP -> IO (CInt)
+
+set_ready :: GuestfsH -> IO ()
+set_ready h = do
+  r <- withForeignPtr h (\p -> c_set_ready p)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_end_busy" c_end_busy
+  :: GuestfsP -> IO (CInt)
+
+end_busy :: GuestfsH -> IO ()
+end_busy h = do
+  r <- withForeignPtr h (\p -> c_end_busy p)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_mount" c_mount
+  :: GuestfsP -> CString -> CString -> IO (CInt)
+
+mount :: GuestfsH -> String -> String -> IO ()
+mount h device mountpoint = do
+  r <- withCString device $ \device -> withCString mountpoint $ \mountpoint -> withForeignPtr h (\p -> c_mount p device mountpoint)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_sync" c_sync
+  :: GuestfsP -> IO (CInt)
+
+sync :: GuestfsH -> IO ()
+sync h = do
+  r <- withForeignPtr h (\p -> c_sync p)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_touch" c_touch
+  :: GuestfsP -> CString -> IO (CInt)
+
+touch :: GuestfsH -> String -> IO ()
+touch h path = do
+  r <- withCString path $ \path -> withForeignPtr h (\p -> c_touch p path)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_aug_close" c_aug_close
+  :: GuestfsP -> IO (CInt)
+
+aug_close :: GuestfsH -> IO ()
+aug_close h = do
+  r <- withForeignPtr h (\p -> c_aug_close p)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_aug_set" c_aug_set
+  :: GuestfsP -> CString -> CString -> IO (CInt)
+
+aug_set :: GuestfsH -> String -> String -> IO ()
+aug_set h path val = do
+  r <- withCString path $ \path -> withCString val $ \val -> withForeignPtr h (\p -> c_aug_set p path val)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_aug_mv" c_aug_mv
+  :: GuestfsP -> CString -> CString -> IO (CInt)
+
+aug_mv :: GuestfsH -> String -> String -> IO ()
+aug_mv h src dest = do
+  r <- withCString src $ \src -> withCString dest $ \dest -> withForeignPtr h (\p -> c_aug_mv p src dest)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_aug_save" c_aug_save
+  :: GuestfsP -> IO (CInt)
+
+aug_save :: GuestfsH -> IO ()
+aug_save h = do
+  r <- withForeignPtr h (\p -> c_aug_save p)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_aug_load" c_aug_load
+  :: GuestfsP -> IO (CInt)
+
+aug_load :: GuestfsH -> IO ()
+aug_load h = do
+  r <- withForeignPtr h (\p -> c_aug_load p)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_rm" c_rm
+  :: GuestfsP -> CString -> IO (CInt)
+
+rm :: GuestfsH -> String -> IO ()
+rm h path = do
+  r <- withCString path $ \path -> withForeignPtr h (\p -> c_rm p path)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_rmdir" c_rmdir
+  :: GuestfsP -> CString -> IO (CInt)
+
+rmdir :: GuestfsH -> String -> IO ()
+rmdir h path = do
+  r <- withCString path $ \path -> withForeignPtr h (\p -> c_rmdir p path)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_rm_rf" c_rm_rf
+  :: GuestfsP -> CString -> IO (CInt)
+
+rm_rf :: GuestfsH -> String -> IO ()
+rm_rf h path = do
+  r <- withCString path $ \path -> withForeignPtr h (\p -> c_rm_rf p path)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_mkdir" c_mkdir
+  :: GuestfsP -> CString -> IO (CInt)
+
+mkdir :: GuestfsH -> String -> IO ()
+mkdir h path = do
+  r <- withCString path $ \path -> withForeignPtr h (\p -> c_mkdir p path)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_mkdir_p" c_mkdir_p
+  :: GuestfsP -> CString -> IO (CInt)
+
+mkdir_p :: GuestfsH -> String -> IO ()
+mkdir_p h path = do
+  r <- withCString path $ \path -> withForeignPtr h (\p -> c_mkdir_p p path)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_pvcreate" c_pvcreate
+  :: GuestfsP -> CString -> IO (CInt)
+
+pvcreate :: GuestfsH -> String -> IO ()
+pvcreate h device = do
+  r <- withCString device $ \device -> withForeignPtr h (\p -> c_pvcreate p device)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_vgcreate" c_vgcreate
+  :: GuestfsP -> CString -> Ptr CString -> IO (CInt)
+
+vgcreate :: GuestfsH -> String -> [String] -> IO ()
+vgcreate h volgroup physvols = do
+  r <- withCString volgroup $ \volgroup -> withMany withCString physvols $ \physvols -> withArray0 nullPtr physvols $ \physvols -> withForeignPtr h (\p -> c_vgcreate p volgroup physvols)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_mkfs" c_mkfs
+  :: GuestfsP -> CString -> CString -> IO (CInt)
+
+mkfs :: GuestfsH -> String -> String -> IO ()
+mkfs h fstype device = do
+  r <- withCString fstype $ \fstype -> withCString device $ \device -> withForeignPtr h (\p -> c_mkfs p fstype device)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_umount" c_umount
+  :: GuestfsP -> CString -> IO (CInt)
+
+umount :: GuestfsH -> String -> IO ()
+umount h pathordevice = do
+  r <- withCString pathordevice $ \pathordevice -> withForeignPtr h (\p -> c_umount p pathordevice)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_umount_all" c_umount_all
+  :: GuestfsP -> IO (CInt)
+
+umount_all :: GuestfsH -> IO ()
+umount_all h = do
+  r <- withForeignPtr h (\p -> c_umount_all p)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_lvm_remove_all" c_lvm_remove_all
+  :: GuestfsP -> IO (CInt)
+
+lvm_remove_all :: GuestfsH -> IO ()
+lvm_remove_all h = do
+  r <- withForeignPtr h (\p -> c_lvm_remove_all p)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_blockdev_setro" c_blockdev_setro
+  :: GuestfsP -> CString -> IO (CInt)
+
+blockdev_setro :: GuestfsH -> String -> IO ()
+blockdev_setro h device = do
+  r <- withCString device $ \device -> withForeignPtr h (\p -> c_blockdev_setro p device)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_blockdev_setrw" c_blockdev_setrw
+  :: GuestfsP -> CString -> IO (CInt)
+
+blockdev_setrw :: GuestfsH -> String -> IO ()
+blockdev_setrw h device = do
+  r <- withCString device $ \device -> withForeignPtr h (\p -> c_blockdev_setrw p device)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_blockdev_flushbufs" c_blockdev_flushbufs
+  :: GuestfsP -> CString -> IO (CInt)
+
+blockdev_flushbufs :: GuestfsH -> String -> IO ()
+blockdev_flushbufs h device = do
+  r <- withCString device $ \device -> withForeignPtr h (\p -> c_blockdev_flushbufs p device)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_blockdev_rereadpt" c_blockdev_rereadpt
+  :: GuestfsP -> CString -> IO (CInt)
+
+blockdev_rereadpt :: GuestfsH -> String -> IO ()
+blockdev_rereadpt h device = do
+  r <- withCString device $ \device -> withForeignPtr h (\p -> c_blockdev_rereadpt p device)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_upload" c_upload
+  :: GuestfsP -> CString -> CString -> IO (CInt)
+
+upload :: GuestfsH -> String -> String -> IO ()
+upload h filename remotefilename = do
+  r <- withCString filename $ \filename -> withCString remotefilename $ \remotefilename -> withForeignPtr h (\p -> c_upload p filename remotefilename)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_download" c_download
+  :: GuestfsP -> CString -> CString -> IO (CInt)
+
+download :: GuestfsH -> String -> String -> IO ()
+download h remotefilename filename = do
+  r <- withCString remotefilename $ \remotefilename -> withCString filename $ \filename -> withForeignPtr h (\p -> c_download p remotefilename filename)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_tar_in" c_tar_in
+  :: GuestfsP -> CString -> CString -> IO (CInt)
+
+tar_in :: GuestfsH -> String -> String -> IO ()
+tar_in h tarfile directory = do
+  r <- withCString tarfile $ \tarfile -> withCString directory $ \directory -> withForeignPtr h (\p -> c_tar_in p tarfile directory)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_tar_out" c_tar_out
+  :: GuestfsP -> CString -> CString -> IO (CInt)
+
+tar_out :: GuestfsH -> String -> String -> IO ()
+tar_out h directory tarfile = do
+  r <- withCString directory $ \directory -> withCString tarfile $ \tarfile -> withForeignPtr h (\p -> c_tar_out p directory tarfile)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_tgz_in" c_tgz_in
+  :: GuestfsP -> CString -> CString -> IO (CInt)
+
+tgz_in :: GuestfsH -> String -> String -> IO ()
+tgz_in h tarball directory = do
+  r <- withCString tarball $ \tarball -> withCString directory $ \directory -> withForeignPtr h (\p -> c_tgz_in p tarball directory)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_tgz_out" c_tgz_out
+  :: GuestfsP -> CString -> CString -> IO (CInt)
+
+tgz_out :: GuestfsH -> String -> String -> IO ()
+tgz_out h directory tarball = do
+  r <- withCString directory $ \directory -> withCString tarball $ \tarball -> withForeignPtr h (\p -> c_tgz_out p directory tarball)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_mount_ro" c_mount_ro
+  :: GuestfsP -> CString -> CString -> IO (CInt)
+
+mount_ro :: GuestfsH -> String -> String -> IO ()
+mount_ro h device mountpoint = do
+  r <- withCString device $ \device -> withCString mountpoint $ \mountpoint -> withForeignPtr h (\p -> c_mount_ro p device mountpoint)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_mount_options" c_mount_options
+  :: GuestfsP -> CString -> CString -> CString -> IO (CInt)
+
+mount_options :: GuestfsH -> String -> String -> String -> IO ()
+mount_options h options device mountpoint = do
+  r <- withCString options $ \options -> withCString device $ \device -> withCString mountpoint $ \mountpoint -> withForeignPtr h (\p -> c_mount_options p options device mountpoint)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_mount_vfs" c_mount_vfs
+  :: GuestfsP -> CString -> CString -> CString -> CString -> IO (CInt)
+
+mount_vfs :: GuestfsH -> String -> String -> String -> String -> IO ()
+mount_vfs h options vfstype device mountpoint = do
+  r <- withCString options $ \options -> withCString vfstype $ \vfstype -> withCString device $ \device -> withCString mountpoint $ \mountpoint -> withForeignPtr h (\p -> c_mount_vfs p options vfstype device mountpoint)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_lvremove" c_lvremove
+  :: GuestfsP -> CString -> IO (CInt)
+
+lvremove :: GuestfsH -> String -> IO ()
+lvremove h device = do
+  r <- withCString device $ \device -> withForeignPtr h (\p -> c_lvremove p device)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_vgremove" c_vgremove
+  :: GuestfsP -> CString -> IO (CInt)
+
+vgremove :: GuestfsH -> String -> IO ()
+vgremove h vgname = do
+  r <- withCString vgname $ \vgname -> withForeignPtr h (\p -> c_vgremove p vgname)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_pvremove" c_pvremove
+  :: GuestfsP -> CString -> IO (CInt)
+
+pvremove :: GuestfsH -> String -> IO ()
+pvremove h device = do
+  r <- withCString device $ \device -> withForeignPtr h (\p -> c_pvremove p device)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_set_e2label" c_set_e2label
+  :: GuestfsP -> CString -> CString -> IO (CInt)
+
+set_e2label :: GuestfsH -> String -> String -> IO ()
+set_e2label h device label = do
+  r <- withCString device $ \device -> withCString label $ \label -> withForeignPtr h (\p -> c_set_e2label p device label)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_set_e2uuid" c_set_e2uuid
+  :: GuestfsP -> CString -> CString -> IO (CInt)
+
+set_e2uuid :: GuestfsH -> String -> String -> IO ()
+set_e2uuid h device uuid = do
+  r <- withCString device $ \device -> withCString uuid $ \uuid -> withForeignPtr h (\p -> c_set_e2uuid p device uuid)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_zero" c_zero
+  :: GuestfsP -> CString -> IO (CInt)
+
+zero :: GuestfsH -> String -> IO ()
+zero h device = do
+  r <- withCString device $ \device -> withForeignPtr h (\p -> c_zero p device)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_grub_install" c_grub_install
+  :: GuestfsP -> CString -> CString -> IO (CInt)
+
+grub_install :: GuestfsH -> String -> String -> IO ()
+grub_install h root device = do
+  r <- withCString root $ \root -> withCString device $ \device -> withForeignPtr h (\p -> c_grub_install p root device)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_cp" c_cp
+  :: GuestfsP -> CString -> CString -> IO (CInt)
+
+cp :: GuestfsH -> String -> String -> IO ()
+cp h src dest = do
+  r <- withCString src $ \src -> withCString dest $ \dest -> withForeignPtr h (\p -> c_cp p src dest)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_cp_a" c_cp_a
+  :: GuestfsP -> CString -> CString -> IO (CInt)
+
+cp_a :: GuestfsH -> String -> String -> IO ()
+cp_a h src dest = do
+  r <- withCString src $ \src -> withCString dest $ \dest -> withForeignPtr h (\p -> c_cp_a p src dest)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_mv" c_mv
+  :: GuestfsP -> CString -> CString -> IO (CInt)
+
+mv :: GuestfsH -> String -> String -> IO ()
+mv h src dest = do
+  r <- withCString src $ \src -> withCString dest $ \dest -> withForeignPtr h (\p -> c_mv p src dest)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
+foreign import ccall unsafe "guestfs_ping_daemon" c_ping_daemon
+  :: GuestfsP -> IO (CInt)
+
+ping_daemon :: GuestfsH -> IO ()
+ping_daemon h = do
+  r <- withForeignPtr h (\p -> c_ping_daemon p)
+  if (r == -1)
+    then do
+      err <- last_error h
+      fail err
+    else return ()
+
diff --git a/haskell/Guestfs005Load.hs b/haskell/Guestfs005Load.hs
new file mode 100644 (file)
index 0000000..c7cb167
--- /dev/null
@@ -0,0 +1,23 @@
+{- libguestfs Haskell bindings
+   Copyright (C) 2009 Red Hat Inc.
+
+   This program is free software; you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 2 of the License, or
+   (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with this program; if not, write to the Free Software
+   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+-}
+
+module Guestfs005Load where
+import qualified Guestfs
+
+main = do
+  Guestfs.create
diff --git a/haskell/Guestfs010Launch.hs b/haskell/Guestfs010Launch.hs
new file mode 100644 (file)
index 0000000..27e49f7
--- /dev/null
@@ -0,0 +1,32 @@
+{- libguestfs Haskell bindings
+   Copyright (C) 2009 Red Hat Inc.
+
+   This program is free software; you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 2 of the License, or
+   (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with this program; if not, write to the Free Software
+   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+-}
+
+module Guestfs010Launch where
+import qualified Guestfs
+import System.IO (openFile, hClose, hSetFileSize, IOMode(WriteMode))
+import System.Posix.Files (removeLink)
+
+main = do
+  g <- Guestfs.create
+  fd <- openFile "test.img" WriteMode
+  hSetFileSize fd (500 * 1024 * 1024)
+  hClose fd
+  Guestfs.add_drive g "test.img"
+  Guestfs.launch g
+  Guestfs.wait_ready g
+  removeLink "test.img"
diff --git a/haskell/Guestfs050LVCreate.hs b/haskell/Guestfs050LVCreate.hs
new file mode 100644 (file)
index 0000000..b82bf0d
--- /dev/null
@@ -0,0 +1,42 @@
+{- libguestfs Haskell bindings
+   Copyright (C) 2009 Red Hat Inc.
+
+   This program is free software; you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 2 of the License, or
+   (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with this program; if not, write to the Free Software
+   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+-}
+
+module Guestfs050LVCreate where
+import qualified Guestfs
+import System.IO (openFile, hClose, hSetFileSize, IOMode(WriteMode))
+import System.Posix.Files (removeLink)
+
+main = do
+  g <- Guestfs.create
+  fd <- openFile "test.img" WriteMode
+  hSetFileSize fd (500 * 1024 * 1024)
+  hClose fd
+  Guestfs.add_drive g "test.img"
+  Guestfs.launch g
+  Guestfs.wait_ready g
+
+  Guestfs.pvcreate g "/dev/sda"
+  Guestfs.vgcreate g "VG" ["/dev/sda"]
+  -- Guestfs.lvcreate g "LV1" "VG" 200
+  -- Guestfs.lvcreate g "LV2" "VG" 200
+
+  -- Guestfs.lvs g and check returned list
+
+  Guestfs.sync g
+
+  removeLink "test.img"
diff --git a/haskell/Makefile.am b/haskell/Makefile.am
new file mode 100644 (file)
index 0000000..06efdfd
--- /dev/null
@@ -0,0 +1,42 @@
+# libguestfs Haskell bindings
+# Copyright (C) 2009 Red Hat Inc.
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program; if not, write to the Free Software
+# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+EXTRA_DIST = *.hs
+
+CLEANFILES = *~
+
+if HAVE_HASKELL
+
+TESTS_ENVIRONMENT = \
+       LD_LIBRARY_PATH=$(abs_top_builddir)/src/.libs \
+       LIBGUESTFS_PATH=$(abs_top_builddir) \
+       $(VG)
+
+TESTS = Guestfs005Load Guestfs010Launch Guestfs050LVCreate
+
+GHCFLAGS = -I$(abs_top_builddir)/src -L$(abs_top_builddir)/src/.libs
+
+Guestfs005Load: Guestfs005Load.hs Guestfs.hs
+       $(GHC)  $(GHCFLAGS) -main-is $(shell basename $@) --make -o $@ $< -lguestfs
+
+Guestfs010Launch: Guestfs010Launch.hs Guestfs.hs
+       $(GHC)  $(GHCFLAGS) -main-is $(shell basename $@) --make -o $@ $< -lguestfs
+
+Guestfs050LVCreate: Guestfs050LVCreate.hs Guestfs.hs
+       $(GHC)  $(GHCFLAGS) -main-is $(shell basename $@) --make -o $@ $< -lguestfs
+
+endif
\ No newline at end of file
index 5b6e1eb..f7057d0 100755 (executable)
@@ -2214,14 +2214,15 @@ let chan = ref stdout
 let pr fs = ksprintf (output_string !chan) fs
 
 (* Generate a header block in a number of standard styles. *)
 let pr fs = ksprintf (output_string !chan) fs
 
 (* Generate a header block in a number of standard styles. *)
-type comment_style = CStyle | HashStyle | OCamlStyle
+type comment_style = CStyle | HashStyle | OCamlStyle | HaskellStyle
 type license = GPLv2 | LGPLv2
 
 let generate_header comment license =
   let c = match comment with
     | CStyle ->     pr "/* "; " *"
     | HashStyle ->  pr "# ";  "#"
 type license = GPLv2 | LGPLv2
 
 let generate_header comment license =
   let c = match comment with
     | CStyle ->     pr "/* "; " *"
     | HashStyle ->  pr "# ";  "#"
-    | OCamlStyle -> pr "(* "; " *" in
+    | OCamlStyle -> pr "(* "; " *"
+    | HaskellStyle -> pr "{- "; "  " in
   pr "libguestfs generated file\n";
   pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c;
   pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
   pr "libguestfs generated file\n";
   pr "%s WARNING: THIS FILE IS GENERATED BY 'src/generator.ml'.\n" c;
   pr "%s ANY CHANGES YOU MAKE TO THIS FILE WILL BE LOST.\n" c;
@@ -2263,6 +2264,7 @@ let generate_header comment license =
    | CStyle -> pr " */\n"
    | HashStyle -> ()
    | OCamlStyle -> pr " *)\n"
    | CStyle -> pr " */\n"
    | HashStyle -> ()
    | OCamlStyle -> pr " *)\n"
+   | HaskellStyle -> pr "-}\n"
   );
   pr "\n"
 
   );
   pr "\n"
 
@@ -6528,6 +6530,207 @@ and generate_java_lvm_return typ jtyp cols =
   pr "  guestfs_free_lvm_%s_list (r);\n" typ;
   pr "  return jr;\n"
 
   pr "  guestfs_free_lvm_%s_list (r);\n" typ;
   pr "  return jr;\n"
 
+and generate_haskell_hs () =
+  generate_header HaskellStyle LGPLv2;
+
+  (* XXX We only know how to generate partial FFI for Haskell
+   * at the moment.  Please help out!
+   *)
+  let can_generate style =
+    let check_no_bad_args =
+      List.for_all (function Bool _ | Int _ -> false | _ -> true)
+    in
+    match style with
+    | RErr, args -> check_no_bad_args args
+    | RBool _, _
+    | RInt _, _
+    | RInt64 _, _
+    | RConstString _, _
+    | RString _, _
+    | RStringList _, _
+    | RIntBool _, _
+    | RPVList _, _
+    | RVGList _, _
+    | RLVList _, _
+    | RStat _, _
+    | RStatVFS _, _
+    | RHashtable _, _ -> false in
+
+  pr "\
+{-# INCLUDE <guestfs.h> #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Guestfs (
+  create";
+
+  (* List out the names of the actions we want to export. *)
+  List.iter (
+    fun (name, style, _, _, _, _, _) ->
+      if can_generate style then pr ",\n  %s" name
+  ) all_functions;
+
+  pr "
+  ) where
+import Foreign
+import Foreign.C
+import IO
+import Control.Exception
+import Data.Typeable
+
+data GuestfsS = GuestfsS            -- represents the opaque C struct
+type GuestfsP = Ptr GuestfsS        -- guestfs_h *
+type GuestfsH = ForeignPtr GuestfsS -- guestfs_h * with attached finalizer
+
+-- XXX define properly later XXX
+data PV = PV
+data VG = VG
+data LV = LV
+data IntBool = IntBool
+data Stat = Stat
+data StatVFS = StatVFS
+data Hashtable = Hashtable
+
+foreign import ccall unsafe \"guestfs_create\" c_create
+  :: IO GuestfsP
+foreign import ccall unsafe \"&guestfs_close\" c_close
+  :: FunPtr (GuestfsP -> IO ())
+foreign import ccall unsafe \"guestfs_set_error_handler\" c_set_error_handler
+  :: GuestfsP -> Ptr CInt -> Ptr CInt -> IO ()
+
+create :: IO GuestfsH
+create = do
+  p <- c_create
+  c_set_error_handler p nullPtr nullPtr
+  h <- newForeignPtr c_close p
+  return h
+
+foreign import ccall unsafe \"guestfs_last_error\" c_last_error
+  :: GuestfsP -> IO CString
+
+-- last_error :: GuestfsH -> IO (Maybe String)
+-- last_error h = do
+--   str <- withForeignPtr h (\\p -> c_last_error p)
+--   maybePeek peekCString str
+
+last_error :: GuestfsH -> IO (String)
+last_error h = do
+  str <- withForeignPtr h (\\p -> c_last_error p)
+  if (str == nullPtr)
+    then return \"no error\"
+    else peekCString str
+
+";
+
+  (* Generate wrappers for each foreign function. *)
+  List.iter (
+    fun (name, style, _, _, _, _, _) ->
+      if can_generate style then (
+       pr "foreign import ccall unsafe \"guestfs_%s\" c_%s\n" name name;
+       pr "  :: ";
+       generate_haskell_prototype ~handle:"GuestfsP" style;
+       pr "\n";
+       pr "\n";
+       pr "%s :: " name;
+       generate_haskell_prototype ~handle:"GuestfsH" ~hs:true style;
+       pr "\n";
+       pr "%s %s = do\n" name
+         (String.concat " " ("h" :: List.map name_of_argt (snd style)));
+       pr "  r <- ";
+       List.iter (
+         function
+         | FileIn n
+         | FileOut n
+         | String n -> pr "withCString %s $ \\%s -> " n n
+         | OptString n -> pr "maybeWith withCString %s $ \\%s -> " n n
+         | StringList n -> pr "withMany withCString %s $ \\%s -> withArray0 nullPtr %s $ \\%s -> " n n n n
+         | Bool n ->
+             (* XXX this doesn't work *)
+             pr "      let\n";
+             pr "        %s = case %s of\n" n n;
+             pr "          False -> 0\n";
+             pr "          True -> 1\n";
+             pr "      in fromIntegral %s $ \\%s ->\n" n n
+         | Int n -> pr "fromIntegral %s $ \\%s -> " n n
+       ) (snd style);
+       pr "withForeignPtr h (\\p -> c_%s %s)\n" name
+         (String.concat " " ("p" :: List.map name_of_argt (snd style)));
+       (match fst style with
+        | RErr | RInt _ | RInt64 _ | RBool _ ->
+            pr "  if (r == -1)\n";
+            pr "    then do\n";
+            pr "      err <- last_error h\n";
+            pr "      fail err\n";
+        | RConstString _ | RString _ | RStringList _ | RIntBool _
+        | RPVList _ | RVGList _ | RLVList _ | RStat _ | RStatVFS _
+        | RHashtable _ ->
+            pr "  if (r == nullPtr)\n";
+            pr "    then do\n";
+            pr "      err <- last_error h\n";
+            pr "      fail err\n";
+       );
+       (match fst style with
+        | RErr ->
+            pr "    else return ()\n"
+        | RInt _ ->
+            pr "    else return (fromIntegral r)\n"
+        | RInt64 _ ->
+            pr "    else return (fromIntegral r)\n"
+        | RBool _ ->
+            pr "    else return (toBool r)\n"
+        | RConstString _
+        | RString _
+        | RStringList _
+        | RIntBool _
+        | RPVList _
+        | RVGList _
+        | RLVList _
+        | RStat _
+        | RStatVFS _
+        | RHashtable _ ->
+            pr "    else return ()\n" (* XXXXXXXXXXXXXXXXXXXX *)
+       );
+       pr "\n";
+      )
+  ) all_functions
+
+and generate_haskell_prototype ~handle ?(hs = false) style =
+  pr "%s -> " handle;
+  let string = if hs then "String" else "CString" in
+  let int = if hs then "Int" else "CInt" in
+  let bool = if hs then "Bool" else "CInt" in
+  let int64 = if hs then "Integer" else "Int64" in
+  List.iter (
+    fun arg ->
+      (match arg with
+       | String _ -> pr "%s" string
+       | OptString _ -> if hs then pr "Maybe String" else pr "CString"
+       | StringList _ -> if hs then pr "[String]" else pr "Ptr CString"
+       | Bool _ -> pr "%s" bool
+       | Int _ -> pr "%s" int
+       | FileIn _ -> pr "%s" string
+       | FileOut _ -> pr "%s" string
+      );
+      pr " -> ";
+  ) (snd style);
+  pr "IO (";
+  (match fst style with
+   | RErr -> if not hs then pr "CInt"
+   | RInt _ -> pr "%s" int
+   | RInt64 _ -> pr "%s" int64
+   | RBool _ -> pr "%s" bool
+   | RConstString _ -> pr "%s" string
+   | RString _ -> pr "%s" string
+   | RStringList _ -> pr "[%s]" string
+   | RIntBool _ -> pr "IntBool"
+   | RPVList _ -> pr "[PV]"
+   | RVGList _ -> pr "[VG]"
+   | RLVList _ -> pr "[LV]"
+   | RStat _ -> pr "Stat"
+   | RStatVFS _ -> pr "StatVFS"
+   | RHashtable _ -> pr "Hashtable"
+  );
+  pr ")"
+
 let output_to filename =
   let filename_new = filename ^ ".new" in
   chan := open_out filename_new;
 let output_to filename =
   let filename_new = filename ^ ".new" in
   chan := open_out filename_new;
@@ -6668,3 +6871,7 @@ Run it from the top source directory using the command
   let close = output_to "java/com_redhat_et_libguestfs_GuestFS.c" in
   generate_java_c ();
   close ();
   let close = output_to "java/com_redhat_et_libguestfs_GuestFS.c" in
   generate_java_c ();
   close ();
+
+  let close = output_to "haskell/Guestfs.hs" in
+  generate_haskell_hs ();
+  close ();