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 ")"