use Win32 API with MLton FFI

dynlink.sml

(**
 * import from sample code
 * > https://raw.github.com/MLton/mlton/master/doc/examples/ffi/iimport.sml
 *)
signature DYN_LINK =
   sig
      type hndl
      type mode
      type fptr

      val dlopen : string * mode -> hndl
      val dlsym : hndl * string -> fptr
      val dlclose : hndl -> unit

      val RTLD_LAZY : mode
      val RTLD_NOW : mode
   end

structure DynLink :> DYN_LINK =
   struct
      type hndl = MLton.Pointer.t
      type mode = Word32.word
      type fptr = MLton.Pointer.t

      (* These symbols come from a system libray, so the default import scope
       * of external is correct.
       *)
      val dlopen =
         _import "dlopen" : string * mode -> hndl;
      val dlerror =
         _import "dlerror": unit -> MLton.Pointer.t;
      val dlsym =
         _import "dlsym" : hndl * string -> fptr;
      val dlclose =
         _import "dlclose" : hndl -> Int32.int;

      val RTLD_LAZY = 0wx00001 (* Lazy function call binding.  *)
      val RTLD_NOW  = 0wx00002 (* Immediate function call binding.  *)

      val dlerror = fn () =>
         let
            val addr = dlerror ()
         in
            if addr = MLton.Pointer.null
               then NONE
               else let
                       fun loop (index, cs) =
                          let
                             val w = MLton.Pointer.getWord8 (addr, index)
                             val c = Byte.byteToChar w
                          in
                             if c = #"\000"
                                then SOME (implode (rev cs))
                                else loop (index + 1, c::cs)
                          end
                    in
                       loop (0, [])
                    end
         end

      val dlopen = fn (filename, mode) =>
         let
            val filename = filename ^ "\000"
            val hndl = dlopen (filename, mode)
         in
            if hndl = MLton.Pointer.null
               then raise Fail (case dlerror () of
                                   NONE => "???"
                                 | SOME s => s)
               else hndl
         end

      val dlsym = fn (hndl, symbol) =>
         let
            val symbol = symbol ^ "\000"
            val fptr = dlsym (hndl, symbol)
         in
            case dlerror () of
               NONE => fptr
             | SOME s => raise Fail s
         end

      val dlclose = fn hndl =>
         if MLton.Platform.OS.host = MLton.Platform.OS.Darwin
            then ()  (* Darwin reports the following error message if you
                      * try to close a dynamic library.
                      *   "dynamic libraries cannot be closed"
                      * So, we disable dlclose on Darwin.
                      *)
         else
            let
               val res = dlclose hndl
            in
               if res = 0
                  then ()
               else raise Fail (case dlerror () of
                                   NONE => "???"
                                 | SOME s => s)
            end
   end

win32.mlb

ann "allowFFI true" in
	$(SML_LIB)/basis/basis.mlb
	$(SML_LIB)/basis/mlton.mlb
	$(SML_LIB)/basis/c-types.mlb
	dynlink.sml
	win32.sml
end

win32.sml

(**
 * $ mlton win32.mlb
 * $ ./win32
 *)
local
  val MessageBoxA = _import "MessageBoxA" stdcall: C_Pointer.t * string * string * Word32.word -> int;
in
  val _ = MessageBoxA (C_Pointer.null, "Hello World!", "MLton Static FFI", 0w4096)
end

local
  val double_to_double = _import * : DynLink.fptr -> real -> real;
  val user32 = DynLink.dlopen ("user32.dll", DynLink.RTLD_LAZY)
  val sigMessageBoxA =
    _import * : DynLink.fptr -> C_Pointer.t * string * string * Word32.word -> int;
  val msgbox_ptr = DynLink.dlsym (user32, "MessageBoxA")
  val dynMessageBoxA = sigMessageBoxA msgbox_ptr
in
  val _ = dynMessageBoxA (C_Pointer.null, "Hello World!", "MLton Dynamic FFI", 0w4096)
  val _ = DynLink.dlclose user32
end