mirror of
https://github.com/libguestfs/libguestfs.git
synced 2026-03-22 07:03:38 +00:00
6cc521dc45
Look for use of external_functions and fish_functions and replace with use of external_functions_sorted and fish_functions_sorted where possible. This ensures that the output of the generator is sorted as far as possible. I also checked for uses of internal_functions and documented_functions but those are not used. The *_sorted versions are always used instead.
301 lines
9.2 KiB
OCaml
301 lines
9.2 KiB
OCaml
(* libguestfs
|
|
* Copyright (C) 2009-2014 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
|
*)
|
|
|
|
(* Please read generator/README first. *)
|
|
|
|
open Printf
|
|
|
|
open Types
|
|
open Utils
|
|
open Pr
|
|
open Docstrings
|
|
open Optgroups
|
|
open Actions
|
|
open Structs
|
|
|
|
let rec generate_haskell_hs () =
|
|
generate_header HaskellStyle LGPLv2plus;
|
|
|
|
(* See guestfs(3)/Haskell for limitations of the current Haskell
|
|
* bindings. Please help out! XXX
|
|
*)
|
|
let can_generate = function
|
|
| _, _, (_::_) -> false (* no optional args yet *)
|
|
| RErr, _, []
|
|
| RInt _, _, []
|
|
| RInt64 _, _, []
|
|
| RBool _, _, []
|
|
| RConstString _, _, []
|
|
| RString _, _, []
|
|
| RStringList _, _, []
|
|
| RHashtable _, _, [] -> true
|
|
| RStruct _, _, []
|
|
| RStructList _, _, []
|
|
| RBufferOut _, _, []
|
|
| RConstOptString _, _, [] -> false
|
|
in
|
|
|
|
pr "\
|
|
{-# LANGUAGE ForeignFunctionInterface #-}
|
|
|
|
module Guestfs (
|
|
create";
|
|
|
|
(* List out the names of the actions we want to export. *)
|
|
List.iter (
|
|
fun { name = name; style = style } ->
|
|
if can_generate style then pr ",\n %s" name
|
|
) external_functions_sorted;
|
|
|
|
pr "
|
|
) where
|
|
|
|
-- Unfortunately some symbols duplicate ones already present
|
|
-- in Prelude. We don't know which, so we hard-code a list
|
|
-- here.
|
|
import Prelude hiding (head, tail, truncate)
|
|
|
|
import Foreign
|
|
import Foreign.C
|
|
import Foreign.C.Types
|
|
import System.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
|
|
|
|
foreign import ccall unsafe \"guestfs.h guestfs_create\" c_create
|
|
:: IO GuestfsP
|
|
foreign import ccall unsafe \"guestfs.h &guestfs_close\" c_close
|
|
:: FunPtr (GuestfsP -> IO ())
|
|
foreign import ccall unsafe \"guestfs.h 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.h 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
|
|
|
|
assocListOfHashtable :: Eq a => [a] -> [(a,a)]
|
|
assocListOfHashtable [] = []
|
|
assocListOfHashtable [a] =
|
|
fail \"RHashtable returned an odd number of elements\"
|
|
assocListOfHashtable (a:b:rest) = (a,b) : assocListOfHashtable rest
|
|
|
|
";
|
|
|
|
(* Generate wrappers for each foreign function. *)
|
|
List.iter (
|
|
fun { name = name; style = (ret, args, optargs as style);
|
|
c_function = c_function } ->
|
|
if can_generate style then (
|
|
pr "foreign import ccall unsafe \"guestfs.h %s\" c_%s\n"
|
|
c_function 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 args));
|
|
pr " r <- ";
|
|
(* Convert pointer arguments using with* functions. *)
|
|
List.iter (
|
|
function
|
|
| FileIn n
|
|
| FileOut n
|
|
| Pathname n | Device n | Mountable n
|
|
| Dev_or_Path n | Mountable_or_Path n | String n
|
|
| Key n | GUID n ->
|
|
pr "withCString %s $ \\%s -> " n n
|
|
| BufferIn n ->
|
|
pr "withCStringLen %s $ \\(%s, %s_size) -> " n n n
|
|
| OptString n -> pr "maybeWith withCString %s $ \\%s -> " n n
|
|
| StringList n | DeviceList n -> pr "withMany withCString %s $ \\%s -> withArray0 nullPtr %s $ \\%s -> " n n n n
|
|
| Bool _ | Int _ | Int64 _ | Pointer _ -> ()
|
|
) args;
|
|
(* Convert integer arguments. *)
|
|
let args =
|
|
List.map (
|
|
function
|
|
| Bool n -> sprintf "(fromBool %s)" n
|
|
| Int n -> sprintf "(fromIntegral %s)" n
|
|
| Int64 n | Pointer (_, n) -> sprintf "(fromIntegral %s)" n
|
|
| FileIn n | FileOut n
|
|
| Pathname n | Device n | Mountable n
|
|
| Dev_or_Path n | Mountable_or_Path n
|
|
| String n | OptString n
|
|
| StringList n | DeviceList n
|
|
| Key n | GUID n -> n
|
|
| BufferIn n -> sprintf "%s (fromIntegral %s_size)" n n
|
|
) args in
|
|
pr "withForeignPtr h (\\p -> c_%s %s)\n" name
|
|
(String.concat " " ("p" :: args));
|
|
(match ret 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 _ | RConstOptString _ | RString _
|
|
| RStringList _ | RStruct _
|
|
| RStructList _ | RHashtable _ | RBufferOut _ ->
|
|
pr " if (r == nullPtr)\n";
|
|
pr " then do\n";
|
|
pr " err <- last_error h\n";
|
|
pr " fail err\n";
|
|
);
|
|
(match ret 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 _ ->
|
|
pr " else peekCString r\n"
|
|
| RStringList _ ->
|
|
pr " else peekArray0 nullPtr r >>= mapM peekCString\n"
|
|
| RHashtable _ ->
|
|
pr " else do\n";
|
|
pr " arr <- peekArray0 nullPtr r\n";
|
|
pr " arr <- mapM peekCString arr\n";
|
|
pr " return (assocListOfHashtable arr)\n"
|
|
| RStruct _
|
|
| RStructList _
|
|
| RBufferOut _
|
|
| RConstOptString _ ->
|
|
pr " else return ()\n" (* XXXXXXXXXXXXXXXXXXXX *)
|
|
);
|
|
pr "\n";
|
|
)
|
|
) external_functions_sorted
|
|
|
|
and generate_haskell_prototype ~handle ?(hs = false) (ret, args, optargs) =
|
|
pr "%s -> " handle;
|
|
if not hs then (
|
|
List.iter (
|
|
fun arg ->
|
|
(match arg with
|
|
| Pathname _ | Device _ | Mountable _
|
|
| Dev_or_Path _ | Mountable_or_Path _ | String _
|
|
| Key _ | GUID _ ->
|
|
pr "CString"
|
|
| BufferIn _ ->
|
|
pr "CString -> CInt"
|
|
| OptString _ ->
|
|
pr "CString"
|
|
| StringList _ | DeviceList _ ->
|
|
pr "Ptr CString"
|
|
| Bool _ -> pr "CInt"
|
|
| Int _ -> pr "CInt"
|
|
| Int64 _ -> pr "Int64"
|
|
| Pointer _ -> pr "CInt"
|
|
| FileIn _ -> pr "CString"
|
|
| FileOut _ -> pr "CString"
|
|
);
|
|
pr " -> ";
|
|
) args;
|
|
pr "IO ";
|
|
(match ret with
|
|
| RErr -> pr "CInt"
|
|
| RInt _ -> pr "CInt"
|
|
| RInt64 _ -> pr "Int64"
|
|
| RBool _ -> pr "CInt"
|
|
| RConstString _ -> pr "CString"
|
|
| RConstOptString _ -> pr "(Maybe CString)"
|
|
| RString _ -> pr "CString"
|
|
| RStringList _ -> pr "(Ptr CString)"
|
|
| RStruct (_, typ) ->
|
|
let name = camel_name_of_struct typ in
|
|
pr "%s" name
|
|
| RStructList (_, typ) ->
|
|
let name = camel_name_of_struct typ in
|
|
pr "[%s]" name
|
|
| RHashtable _ -> pr "(Ptr CString)"
|
|
| RBufferOut _ -> pr "CString"
|
|
)
|
|
)
|
|
else (* hs *) (
|
|
List.iter (
|
|
fun arg ->
|
|
(match arg with
|
|
| Pathname _ | Device _ | Mountable _
|
|
| Dev_or_Path _ | Mountable_or_Path _ | String _
|
|
| Key _ | GUID _ ->
|
|
pr "String"
|
|
| BufferIn _ ->
|
|
pr "String"
|
|
| OptString _ ->
|
|
pr "Maybe String"
|
|
| StringList _ | DeviceList _ ->
|
|
pr "[String]"
|
|
| Bool _ -> pr "Bool"
|
|
| Int _ -> pr "Int"
|
|
| Int64 _ -> pr "Integer"
|
|
| Pointer _ -> pr "Int"
|
|
| FileIn _ -> pr "String"
|
|
| FileOut _ -> pr "String"
|
|
);
|
|
pr " -> ";
|
|
) args;
|
|
pr "IO ";
|
|
(match ret with
|
|
| RErr -> pr "()"
|
|
| RInt _ -> pr "Int"
|
|
| RInt64 _ -> pr "Int64"
|
|
| RBool _ -> pr "Bool"
|
|
| RConstString _ -> pr "String"
|
|
| RConstOptString _ -> pr "(Maybe String)"
|
|
| RString _ -> pr "String"
|
|
| RStringList _ -> pr "[String]"
|
|
| RStruct (_, typ) ->
|
|
let name = camel_name_of_struct typ in
|
|
pr "%s" name
|
|
| RStructList (_, typ) ->
|
|
let name = camel_name_of_struct typ in
|
|
pr "[%s]" name
|
|
| RHashtable _ -> pr "[(String, String)]"
|
|
| RBufferOut _ -> pr "String"
|
|
)
|
|
)
|