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     | RErr, _
  40     | RInt _, _
  41     | RInt64 _, _ -> true
  42     | RBool _, _
  43     | RConstString _, _
  44     | RConstOptString _, _
  45     | RString _, _
  46     | RStringList _, _
  47     | RStruct _, _
  48     | RStructList _, _
  49     | RHashtable _, _
  50     | RBufferOut _, _ -> false in
  51
  52   pr "\
  53 {-# INCLUDE <guestfs.h> #-}
  54 {-# LANGUAGE ForeignFunctionInterface #-}
  55
  56 module Guestfs (
  57   create";
  58
  59   (* List out the names of the actions we want to export. *)
  60   List.iter (
  61     fun (name, style, _, _, _, _, _) ->
  62       if can_generate style then pr ",\n  %s" name
  63   ) all_functions;
  64
  65   pr "
  66   ) where
  67
  68 -- Unfortunately some symbols duplicate ones already present
  69 -- in Prelude.  We don't know which, so we hard-code a list
  70 -- here.
  71 import Prelude hiding (truncate)
  72
  73 import Foreign
  74 import Foreign.C
  75 import Foreign.C.Types
  76 import IO
  77 import Control.Exception
  78 import Data.Typeable
  79
  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
  83
  84 -- XXX define properly later XXX
  85 data PV = PV
  86 data VG = VG
  87 data LV = LV
  88 data IntBool = IntBool
  89 data Stat = Stat
  90 data StatVFS = StatVFS
  91 data Hashtable = Hashtable
  92
  93 foreign import ccall unsafe \"guestfs_create\" c_create
  94   :: IO GuestfsP
  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 ()
  99
 100 create :: IO GuestfsH
 101 create = do
 102   p <- c_create
 103   c_set_error_handler p nullPtr nullPtr
 104   h <- newForeignPtr c_close p
 105   return h
 106
 107 foreign import ccall unsafe \"guestfs_last_error\" c_last_error
 108   :: GuestfsP -> IO CString
 109
 110 -- last_error :: GuestfsH -> IO (Maybe String)
 111 -- last_error h = do
 112 --   str <- withForeignPtr h (\\p -> c_last_error p)
 113 --   maybePeek peekCString str
 114
 115 last_error :: GuestfsH -> IO (String)
 116 last_error h = do
 117   str <- withForeignPtr h (\\p -> c_last_error p)
 118   if (str == nullPtr)
 119     then return \"no error\"
 120     else peekCString str
 121
 122 ";
 123
 124   (* Generate wrappers for each foreign function. *)
 125   List.iter (
 126     fun (name, style, _, _, _, _, _) ->
 127       if can_generate style then (
 128         pr "foreign import ccall unsafe \"guestfs_%s\" c_%s\n" name name;
 129         pr "  :: ";
 130         generate_haskell_prototype ~handle:"GuestfsP" style;
 131         pr "\n";
 132         pr "\n";
 133         pr "%s :: " name;
 134         generate_haskell_prototype ~handle:"GuestfsH" ~hs:true style;
 135         pr "\n";
 136         pr "%s %s = do\n" name
 137           (String.concat " " ("h" :: List.map name_of_argt (snd style)));
 138         pr "  r <- ";
 139         (* Convert pointer arguments using with* functions. *)
 140         List.iter (
 141           function
 142           | FileIn n
 143           | FileOut n
 144           | Pathname n | Device n | Dev_or_Path n | String n | Key n ->
 145               pr "withCString %s $ \\%s -> " n n
 146           | BufferIn 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 _ -> ()
 151         ) (snd style);
 152         (* Convert integer arguments. *)
 153         let args =
 154           List.map (
 155             function
 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
 163             | Key n -> n
 164             | BufferIn n -> sprintf "%s (fromIntegral %s_size)" n n
 165           ) (snd style) in
 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";
 171              pr "    then do\n";
 172              pr "      err <- last_error h\n";
 173              pr "      fail err\n";
 174          | RConstString _ | RConstOptString _ | RString _
 175          | RStringList _ | RStruct _
 176          | RStructList _ | RHashtable _ | RBufferOut _ ->
 177              pr "  if (r == nullPtr)\n";
 178              pr "    then do\n";
 179              pr "      err <- last_error h\n";
 180              pr "      fail err\n";
 181         );
 182         (match fst style with
 183          | RErr ->
 184              pr "    else return ()\n"
 185          | RInt _ ->
 186              pr "    else return (fromIntegral r)\n"
 187          | RInt64 _ ->
 188              pr "    else return (fromIntegral r)\n"
 189          | RBool _ ->
 190              pr "    else return (toBool r)\n"
 191          | RConstString _
 192          | RConstOptString _
 193          | RString _
 194          | RStringList _
 195          | RStruct _
 196          | RStructList _
 197          | RHashtable _
 198          | RBufferOut _ ->
 199              pr "    else return ()\n" (* XXXXXXXXXXXXXXXXXXXX *)
 200         );
 201         pr "\n";
 202       )
 203   ) all_functions
 204
 205 and generate_haskell_prototype ~handle ?(hs = false) style =
 206   pr "%s -> " handle;
 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
 211   List.iter (
 212     fun arg ->
 213       (match arg with
 214        | Pathname _ | Device _ | Dev_or_Path _ | String _ | Key _ ->
 215            pr "%s" string
 216        | BufferIn _ ->
 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
 226       );
 227       pr " -> ";
 228   ) (snd style);
 229   pr "IO (";
 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
 241        pr "%s" name
 242    | RStructList (_, typ) ->
 243        let name = java_name_of_struct typ in
 244        pr "[%s]" name
 245    | RHashtable _ -> pr "Hashtable"
 246    | RBufferOut _ -> pr "%s" string
 247   );
 248   pr ")"