(* OCaml-Win32
 * win32_tooltip.ml
 * Copyright (c) 2002-2004 by Harry Chomsky
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Library 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
 * Library General Public License for more details.
 *
 * You should have received a copy of the GNU Library General Public
 * License along with this library; if not, write to the Free
 * Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 *)

open Win32_core

(********************************************************************)
(* User Interface: Windows User Experience: Windows Shell: SDK: Windows Controls: Individual Control Information: ToolTip Controls *)

let tooltips_class = "tooltips_class32"

type tool_id =
    Ti_area of int
  | Ti_wnd of hwnd

type tool_spec =
    Ts_area of int * rect
  | Ts_wnd of hwnd

type tool_text =
    Tt_text of string
  | Tt_resource of hinstance * int
  | Tt_null
  | Tt_callback

type tool_option =
    TTF_ABSOLUTE
  | TTF_CENTERTIP
  | TTF_RTLREADING
  | TTF_SUBCLASS
  | TTF_TRACK
  | TTF_TRANSPARENT

type toolinfo = {
    ti_flags : tool_option list;
    ti_wnd : hwnd;
    ti_spec : tool_spec;
    ti_text : tool_text;
    ti_lparam : int32 }

type toolinfo_get_text =
    Tigt_get of int
  | Tigt_ignore

type tooltip_delay_time =
    TTDT_AUTOPOP
  | TTDT_INITIAL
  | TTDT_RESHOW

(* Styles *)

type tooltip_style_option =
    TTS_ALWAYSTIP
  | TTS_NOPREFIX

external tooltip_style_of_option : tooltip_style_option -> style = "tooltip_style_of_option"

let tooltip_style_of_options = special_style_of_options ~special_func:tooltip_style_of_option

(* Messages *)

let ttm_activate = wm_user + 1
external pack_ttm_activate : activate:bool -> message_contents = "pack_ttm_activate"
let unpack_ttm_activate = ignore
let issue_ttm_activate ~sender ~activate = unpack_ttm_activate (sender ~msg:(pack_ttm_activate ~activate))

let ttm_addtool = wm_user + 4
external issue_ttm_addtool : sender:message_sender -> toolinfo:toolinfo -> unit = "issue_ttm_addtool"

let ttm_deltool = wm_user + 5
external issue_ttm_deltool : sender:message_sender -> wnd:hwnd -> id:tool_id -> unit = "issue_ttm_deltool"

let ttm_enumtools = wm_user + 14
external issue_ttm_enumtools : sender:message_sender -> index:int -> get_text:toolinfo_get_text -> toolinfo = "issue_ttm_enumtools"

let ttm_getcurrenttool = wm_user + 15
external issue_ttm_getcurrenttool : sender:message_sender -> get_text:toolinfo_get_text -> toolinfo option = "issue_ttm_getcurrenttool"

let ttm_getdelaytime = wm_user + 21
external pack_ttm_getdelaytime : which:tooltip_delay_time -> message_contents = "pack_ttm_getdelaytime"
external unpack_ttm_getdelaytime : message_result -> int = "unpack_ttm_getdelaytime"
let issue_ttm_getdelaytime ~sender ~which = unpack_ttm_getdelaytime (sender ~msg:(pack_ttm_getdelaytime ~which))

let ttm_getmargin = wm_user + 27
external issue_ttm_getmargin : sender:message_sender -> rect = "issue_ttm_getmargin"

let ttm_getmaxtipwidth = wm_user + 25
let pack_ttm_getmaxtipwidth = pack_simple_message ~id:ttm_getmaxtipwidth
external unpack_ttm_getmaxtipwidth : message_result -> int = "unpack_ttm_getmaxtipwidth"
let issue_ttm_getmaxtipwidth ~sender = unpack_ttm_getmaxtipwidth (sender ~msg:pack_ttm_getmaxtipwidth)

let ttm_gettext = wm_user + 11
(* ... *)

let ttm_gettipbkcolor = wm_user + 22
let pack_ttm_gettipbkcolor = pack_simple_message ~id:ttm_gettipbkcolor
external unpack_ttm_gettipbkcolor : message_result -> color = "unpack_ttm_gettipbkcolor"
let issue_ttm_gettipbkcolor ~sender = unpack_ttm_gettipbkcolor (sender ~msg:pack_ttm_gettipbkcolor)

let ttm_gettiptextcolor = wm_user + 23
let pack_ttm_gettiptextcolor = pack_simple_message ~id:ttm_gettiptextcolor
external unpack_ttm_gettiptextcolor : message_result -> color = "unpack_ttm_gettiptextcolor"
let issue_ttm_gettiptextcolor ~sender = unpack_ttm_gettiptextcolor (sender ~msg:pack_ttm_gettiptextcolor)

let ttm_gettoolcount = wm_user + 13
let pack_ttm_gettoolcount = pack_simple_message ~id:ttm_gettoolcount
external unpack_ttm_gettoolcount : message_result -> int = "unpack_ttm_gettoolcount"
let issue_ttm_gettoolcount ~sender = unpack_ttm_gettoolcount (sender ~msg:pack_ttm_gettoolcount)

let ttm_gettoolinfo = wm_user + 8
external issue_ttm_gettoolinfo : sender:message_sender -> wnd:hwnd -> id:tool_id -> get_text:toolinfo_get_text -> toolinfo = "issue_ttm_gettoolinfo"

let ttm_hittest = wm_user + 10
external issue_ttm_hittest : sender:message_sender -> wnd:hwnd -> pt:point -> get_text:toolinfo_get_text -> toolinfo option = "issue_ttm_hittest"

let ttm_newtoolrect = wm_user + 6
external issue_ttm_newtoolrect : sender:message_sender -> wnd:hwnd -> id:tool_id -> rect:rect -> unit = "issue_ttm_newtoolrect"

let ttm_pop = wm_user + 28
let pack_ttm_pop = pack_simple_message ~id:ttm_pop
let unpack_ttm_pop = ignore
let issue_ttm_pop ~sender = unpack_ttm_pop (sender ~msg:pack_ttm_pop)

let ttm_relayevent = wm_user + 7
external issue_ttm_relayevent : sender:message_sender -> msg:msg -> unit = "issue_ttm_relayevent"

let ttm_setdelaytime = wm_user + 3
external pack_ttm_setdelaytime : which:tooltip_delay_time -> time:int -> message_contents = "pack_ttm_setdelaytime"
let unpack_ttm_setdelaytime = ignore
let issue_ttm_setdelaytime ~sender ~which ~time = unpack_ttm_setdelaytime (sender ~msg:(pack_ttm_setdelaytime ~which ~time))

let ttm_setmargin = wm_user + 26
external issue_ttm_setmargin : sender:message_sender -> margin:rect -> unit = "issue_ttm_setmargin"

let ttm_setmaxtipwidth = wm_user + 24
external pack_ttm_setmaxtipwidth : width:int -> message_contents = "pack_ttm_setmaxtipwidth"
external unpack_ttm_setmaxtipwidth : message_result -> int = "unpack_ttm_setmaxtipwidth"
let issue_ttm_setmaxtipwidth ~sender ~width = unpack_ttm_setmaxtipwidth (sender ~msg:(pack_ttm_setmaxtipwidth ~width))

let ttm_settipbkcolor = wm_user + 19
external pack_ttm_settipbkcolor : color:color -> message_contents = "pack_ttm_settipbkcolor"
let unpack_ttm_settipbkcolor = ignore
let issue_ttm_settipbkcolor ~sender ~color = unpack_ttm_settipbkcolor (sender ~msg:(pack_ttm_settipbkcolor ~color))

let ttm_settiptextcolor = wm_user + 20
external pack_ttm_settiptextcolor : color:color -> message_contents = "pack_ttm_settiptextcolor"
let unpack_ttm_settiptextcolor = ignore
let issue_ttm_settiptextcolor ~sender ~color = unpack_ttm_settiptextcolor (sender ~msg:(pack_ttm_settiptextcolor ~color))

let ttm_settoolinfo = wm_user + 9
external issue_ttm_settoolinfo : sender:message_sender -> toolinfo:toolinfo -> unit = "issue_ttm_settoolinfo"

let ttm_trackactivate = wm_user + 17
external issue_ttm_trackactivate : sender:message_sender -> wnd:hwnd -> id:tool_id -> activate:bool -> unit = "issue_ttm_trackactivate"

let ttm_trackposition = wm_user + 18
external pack_ttm_trackposition : pos:point -> message_contents = "pack_ttm_trackposition"
let unpack_ttm_trackposition = ignore
let issue_ttm_trackposition ~sender ~pos = unpack_ttm_trackposition (sender ~msg:(pack_ttm_trackposition ~pos))

let ttm_update = wm_user + 29
let pack_ttm_update = pack_simple_message ~id:ttm_update
let unpack_ttm_update = ignore
let issue_ttm_update ~sender = unpack_ttm_update (sender ~msg:pack_ttm_update)

let ttm_updatetiptext = wm_user + 12
(* ... *)

let ttm_windowfrompoint = wm_user + 16
external issue_ttm_windowfrompoint : sender:message_sender -> pt:point -> hwnd = "issue_ttm_windowfrompoint"
type ttm_windowfrompoint_handler =
    wnd:hwnd ->
    msg:message_contents ->
    pt:point ->
    hwnd message_handler_result
external deliver_ttm_windowfrompoint :
    handler:ttm_windowfrompoint_handler ->
    wnd:hwnd ->
    msg:message_contents ->
    hwnd message_handler_result = "deliver_ttm_windowfrompoint"
external return_ttm_windowfrompoint : result:hwnd -> message_result = "return_ttm_windowfrompoint"
let on_ttm_windowfrompoint = on_message ~id:ttm_windowfrompoint ~deliver:deliver_ttm_windowfrompoint ~return:return_ttm_windowfrompoint

(* Notifications *)

let ttn_first = -520
let ttn_last = -549

let ttn_getdispinfo = ttn_first - 0
type tooltip_dispinfo = {
    ttdi_text : tool_text;
    ttdi_rtlreading : bool }
let default_tooltip_dispinfo = {
    ttdi_text = Tt_null;
    ttdi_rtlreading = false }
type ttn_getdispinfo_handler =
    wnd:hwnd ->
    msg:message_contents ->
    id:int ->
    hdr:nmhdr ->
    tool_id:tool_id ->
    lparam:int32 ->
    (tooltip_dispinfo * bool) message_handler_result
external on_ttn_getdispinfo :
    ttn_getdispinfo_handler ->
    wnd:hwnd ->
    msg:message_contents ->
    message_result option = "on_ttn_getdispinfo"

let ttn_pop = ttn_first - 2
let on_ttn_pop = on_notify_message ~code:ttn_pop ~unpack:unpack_simple_notify ~return:return_simple_message

let ttn_show = ttn_first - 1
let on_ttn_show = on_notify_message ~code:ttn_show ~unpack:unpack_simple_notify ~return:return_simple_message
