I am working on a program in which I would like to use lablgtk and lwt. I have functions fetching data on lwt threads, then I would like to display the data in a GUI using lablgtk. I am struggling with the integration of lablgtk in the lwt framework. Below is a distilled version that demonstrates my problem which is that I can get the GUI to launch, but then nothing else happens. Any help is greatly appreciated.
(* gtk_and_lwt.ml *)
let (>>=) = Lwt.bind
let locale = GtkMain.Main.init ()
let window = GWindow.window ~width:300 ~height:200 ()
let vbox = GPack.vbox ~border_width:2 ~packing:window#add ()
let my_table =
GPack.table
~rows:1
~columns:2
~row_spacings:5
~col_spacings:5
~border_width:5
~packing:vbox#pack
()
let _ =
GMisc.label
~text:"User Input"
~packing:(my_table#attach ~left:0 ~top:1 ~right:1 ~bottom:2)
()
let my_label =
GMisc.label
~text:"Fetching User Input..."
~packing:(my_table#attach ~left:1 ~top:0 ~right:2 ~bottom:1)
()
let rec get_user_input () =
Lwt_io.read_line Lwt_io.stdin
>>= fun s -> my_label#set_text s |> Lwt.return
>>= get_user_input
let main () =
(* Kill the process when the user clicks the "X" button in top left cornet*)
let _ = window#connect#destroy ~callback:GMain.Main.quit in
window#show ();
Lwt.async (get_user_input);
Lwt.return ## GMain.Main.main ()
let _ = Lwt_main.run ## main ()
I am compiling with ocamlfind ocamlc -g -package lwt,lwt.syntax,lwt.unix,lablgtk2 -linkpkg gtk_and_lwt.ml -o GtkAndLwt
Related
Looking for WebSocketClient example I only found simple example with a single request/response scenario.
Kind of:
type WSClientSimple (url) =
let ws = new ClientWebSocket()
let lockConnection = Object()
let connect() =
lock lockConnection ( fun () ->
if not (ws.State = WebSocketState.Open) then
ws.ConnectAsync(Uri(url), CancellationToken.None)
|> Async.AwaitTask |> Async.RunSynchronously // await
else ()
)
let receive () =
lock lockConnection ( fun () ->
let rec readStream finalText endOfMessage =
let buffer = ArraySegment(Array.zeroCreate<byte> 1024)
let result = ws.ReceiveAsync(buffer, CancellationToken.None) |> Async.AwaitTask |> Async.RunSynchronously
let text = finalText + Encoding.UTF8.GetString (buffer.Array |> Array.take result.Count)
if result.EndOfMessage then text
else readStream text true
readStream "" false
)
let sendRequest jsonMessage =
let bytes = Encoding.UTF8.GetBytes(jsonMessage:string)
let bytesMessage = ArraySegment(bytes, 0, bytes.Length)
if not (ws.State = WebSocketState.Open) then
connect()
// send request...
ws.SendAsync(bytesMessage, WebSocketMessageType.Text, true, CancellationToken.None) |> Async.AwaitTask |> Async.RunSynchronously
// ... read response
receive()
member this.SendRequest request = sendRequest request
Obviously it works with:
[<Test>]
member this.``Receive sequentially`` () =
let client = WSClientSimple("url")
for i in 1..100 do
client.SendRequest "aaa" |> ignore
and also (thanks to the orrible lock) with multiple thread using the same Client:
[<Test>]
member this.``Receive parallel on same client`` () =
let client = WSClientSimple("url")
for _ in 1..100 do
async {
client.SendRequest "aaa" |> ignore
} |> Async.Start
Now, if I really want to get the beast from WebSocket "duplex" cpmmunication I would continuosly read from the socket, send requests without any block, and distribute the received messages to the right call.
So, this is an ongoing receive function that collect all the inbound messages.
type WSClientTest2 (url:string) =
let onMessageReceived = new Event<string>()
let responseMessage = new Event<ResponseMessage>()
let receivedMesasages = System.Collections.Concurrent.ConcurrentQueue<ResponseMessage>()
let responseCallbacks = Map.empty<int, (string -> unit)>
let manageMessage (message:string) =
match message.Split(':') with
| [|id;message|] ->
responseMessage.Trigger {Id=int(id);Message=message}
receivedMesasages.Enqueue {Id=int(id);Message=message}
| _ -> ()
let startReceiving() =
let mutable counter = 1
async {
// simulate receiving from a WebSocket
while true do
System.Threading.Tasks.Task.Delay 100 |> Async.AwaitTask |> Async.RunSynchronously
onMessageReceived.Trigger (sprintf "message %d" counter)
manageMessage (sprintf "%d:message" counter)
counter <- counter + 1
} |> Async.Start
do
startReceiving()
How can I send a request and wait for the correlated response message?
This is my try:
let mutable requestId = 0
let sendRequest message: string =
let requestId = requestId+1
let received = new Event<string>()
let receivedCall = fun (msg:string) ->
received.Trigger msg
responseCallbacks.Add(requestId, receivedCall) |> ignore
let cancel = fun () -> failwith "Timeout"
async {
System.Threading.Thread.Sleep 500 // wait x seconds
cancel()
} |> Async.Start
// simulate send/receive messsage after some time
let generateRequest () =
System.Threading.Thread.Sleep 100 // wait x time for the response
responseMessage.Trigger {Id=requestId; Message=message}
generateRequest()
Async.AwaitEvent(received.Publish, cancel)
|> Async.RunSynchronously
Async.AwaitWaitHandle seems the right thing to use but I don't know how to create a WaitHandle.
I'm using Async.AwaitEvent but it seems not to work.
The cancel() is always called but it does not raise any Exception!
What could be a proper way to wait for an Event while executing a function and then check and return its content?
I also tried to use a Map<id, response> populatd with any inbound message but still I don't know how to "wait" for the proper message and also it probably requires a check for orphan response messages (add complexity).
More in general, if the resulting code is so crappy I would prefer to use a simple API for this Request/Response scenario and use the WebSocket only for a realtime update.
I'm looking for a nice solution, otherwise I think it is not really worth for the sake of performance, not for my needs.
I'm new to Fabulous and MUV model, and I'm trying to implement application that works with BLE. I'm also a bit new to F#, mostly worked with erlang and C# in the past, so a bit lost with external events processing. CrossBluetoothLE.Current.Adapter has DeviceDiscovered event handler (IEvent). What's the most correct way of linking this event handler to the Fabulous update function?
E.g. after I will call CrossBluetoothLE.Current.Adapter.StartScanningForDevicesAsync(), I want that this event handler supply newly discovered devices to the update function.
And if I will do something like this (this is not working):
type MyApp () as app =
inherit Application ()
let deviceDiscovered dispatch =
CrossBluetoothLE.Current.Adapter.DeviceDiscovered.Subscribe (fun x -> dispatch (App.Msg.Discovered x.Device) )
let runner =
App.program
|> Program.withConsoleTrace
|> Program.withSubscription (fun _ -> Cmd.ofSub deviceDiscovered)
|> XamarinFormsProgram.run app
if it works, it will be ok for device discovery because CrossBluetoothLE.Current.Adapter is static. However after device will be discovered, I will need to work with (e.g. receive notifications or replies from it), and it will not be possible to include dynamic device handler into Program.withSubscription.
Not sure whether the Fabulous is applicable here.
Ok, I was able to find some solution and it works now, but the overall architecture looks a bit weird. So generic approach is to create an external mailbox, that will dispatch messages to the MUV loop.
Describe all messages of the MUV in the external module, e.g.:
type Msg =
| Scan
| Discovered of IDevice
| Connect of IDevice
| ClockMsg of System.DateTime
| TextMsg of string
Create type that encapsulates mailbox:
type DispatchFunc = Msgs.Msg -> unit
type State =
| Initialized of DispatchFunc
| NotInitialized
type Mail =
| Dispatch of DispatchFunc
| Msg of Msgs.Msg
| None
let rand = System.Random()
let id = rand.NextDouble()
let postbox = MailboxProcessor.Start(fun inbox ->
let rec messageLoop (state:State) = async{
let! mail = inbox.Receive()
let new_state =
match mail with
| None ->
state
| Msg msg ->
match state with
| NotInitialized -> NotInitialized
| Initialized df ->
df msg
state
| Dispatch df ->
Initialized df
return! messageLoop (new_state)
}
messageLoop (NotInitialized))
let post(o) =
postbox.Post o
Here, mailbox starts with NotInitialized state and wait while application will start. When everything is done, mailbox received dispatch function, that will be used in further dispatching of the external messages to the MUV main loop.
Pass dispatch handler to the mailbox:
type MyApp () as app =
inherit Application ()
// generate initial events + start threads + pass dispatch reference to the mailbox
let initThreads dispatch =
// init & start external (e.g. bluetooth receiver) threads here
// or start them asynchronously from MUV loop
Postbox.post (Postbox.Dispatch dispatch)
()
let runner =
App.program
|> Program.withConsoleTrace
|> Program.withSubscription (fun _ -> Cmd.ofSub initThreads)
|> XamarinFormsProgram.run app
So now, if you want to send event to the MUV from external thread, just start it inside initThreads (or, e.g. from within MUV loop) and use something like: Postbox.post (Postbox.Msg (Msgs.TextMsg "It works!")).
E.g. for my purposes (BLE discovery) it will look like this:
let update msg model =
match msg with
| Msgs.Scan ->
CrossBluetoothLE.Current.Adapter.StopScanningForDevicesAsync() |> Async.AwaitTask |> ignore
CrossBluetoothLE.Current.Adapter.DeviceDiscovered.Subscribe (
fun (a) ->
Postbox.post (Postbox.Msg (Msgs.Discovered a.Device))
()
) |> ignore
CrossBluetoothLE.Current.Adapter.StartScanningForDevicesAsync() |> Async.AwaitTask |> ignore
model, Cmd.none
| Msgs.ClockMsg msg ->
{ model with label = msg.ToString() }, Cmd.none
| Msgs.TextMsg msg ->
{ model with label = msg }, Cmd.none
| Msgs.Discovered d ->
{ model with gattDevices = d::model.gattDevices; label = "Discovered " + d.ToString() }, Cmd.none
| Msgs.Connect d -> { model with connectedDevice = d }, Cmd.none
This is for sure a very ugly solution, but I wasn't able to imagine something more beautiful :(.
I would like to factorize this code :
(* This function is applied to the result of functions below *)
let manage_result r s =
match r with
| Error ( `Msg e ) -> Tsdl.Sdl.log s e;exit 1
| Ok a -> a
(* Examples of function I want to factorize, let's call them f_functions, f for factorize *)
let init () =
let flag = Tsdl.Sdl.Init.everything in
let result = Tsdl.Sdl.init flag in
manage_result result "Init error : %s"
let create_window title w h =
let flag = Tsdl.Sdl.Window.windowed in
let result = Tsdl.Sdl.create_window title ~w:w ~h:h flag in
manage_result result "Create window error : %s"
let get_window_surface window =
let result = Tsdl.Sdl.get_window_surface window in
manage_result result "Get window surface error : %s"
As you can see, the two last lines of all of these f_functions are very similar. I would like to make a function that takes as argument a function ( for example, if I wanted to factorize init, the function passed as a parameter would be Tsdl.Sdl.init) and return a function that return the return value of function passed as an argument AND processed through manage_result.
The difficulty is that I don't know how many argument can the f_functions take.
Any other recommendations is appreciated!
Thank you.
A potential solution might be to use the pipe operator rather than naming the intermediary result
let on_error s r = manage_result r s
let create_window title w h =
let flag = Tsdl.Sdl.Window.windowed in
Tsdl.Sdl.create_window title ~w:w ~h:h flag
|> on_error "Create window error : %s"
Going one step further, we could define a custom operator for the error handling
let ( <!> ) = manage_result
which may make your definition lightweight enough
let create_window title w h =
let flag = Tsdl.Sdl.Window.windowed in
Tsdl.Sdl.create_window title ~w:w ~h:h flag
<!> "Create window error : %s"
I'm trying to create a very simple user interface for my Binary Search Tree project.
I've done all the necessary functions for the BST but my problem is that I can't get a hold on how to reference to a tree variable inside the program so that I can update it and pass it through each program call.
let rec interface endCondition tree =
let option = read_int ()
in
if option = endCondition then
let () = print_string "Thank you for using the program!" in
let () = print_newline ()
in print_newline ()
else
let () =
if option = 1 then
let value = read_int ()
(* line I'm having problems with *)
in let tree = insert tree value
in let () = Printf.printf "Inserted Node: %d" value
in print_newline ()
else if option = 2 then
let () = print_string "Search Node:"
(* search code here *)
in print_newline ()
else
let () = print_string "Lower"
in print_newline ()
in interface endCondition tree;;
Whenever I use the let function it creates a new variable. How can I use the tree passed as parameter?
Thank you very much!
You need to pass the new tree up farther so you can get at it at the end, something like this:
else
let tree' =
if option = 1 then let ... in insert tree value
else if option = 2 then let ... in tree
else let .... in tree
in interface endCondition tree'
How can I set an action to occur on a key release in xmonad?
I don't like menu bars and panels.
Instead of a panel like xmobar I want to have a full screen page of info, (time, currently selected window and workspace etc) appear when I hold down a key combo and then vanish when I let the keys go.
I could code the info page application myself.
I can set the info page to spawn on a key press.
I can not set anything to happen on a key release.
How can I set an action to occur on a key release?
I am considering extending xmonad myself to do this.
I hope I don't have to though because it'd be really annoying.
XMonad passes all received events, including KeyPress events, to the handleEventHook, so this code would be able to react on keyRelease events:
module KeyUp where
import Data.Monoid
import qualified Data.Map as M
import XMonad
import Control.Monad
keyUpEventHook :: Event -> X All
keyUpEventHook e = handle e >> return (All True)
keyUpKeys (XConf{ config = XConfig {XMonad.modMask = modMask} }) = M.fromList $
[ ((modMask, xK_v), io (print "Hi")) ]
handle :: Event -> X ()
handle (KeyEvent {ev_event_type = t, ev_state = m, ev_keycode = code})
| t == keyRelease = withDisplay $ \dpy -> do
s <- io $ keycodeToKeysym dpy code 0
mClean <- cleanMask m
ks <- asks keyUpKeys
userCodeDef () $ whenJust (M.lookup (mClean, s) ks) id
handle _ = return ()
You would use it like that in your xmonad.hs file:
handleEventHook = handleEventHook defaultConfig `mappend`
keyUpEventHook `mappend`
fullscreenEventHook
Unfortunately, this does not work yet: It will only react on KeyRelease events that have a corresponding entry in the regular keys configuration. This is due to grayKeys in XMonad.Main, grabbing only keys mentioned in keys. You can work-around this by defining a dummy action for every combination that you want to handle in KeyUp:
myKeys conf#(XConfig {XMonad.modMask = modMask}) = M.fromList $
...
, ((modMask , xK_v ), return ())
myStartupHook :: X ()
myStartupHook = do
XConf { display = dpy, theRoot = rootw } <- ask
myKeyCode <- io $ (keysymToKeycode dpy xK_Super_R)
io $ grabKey dpy (myKeyCode) anyModifier rootw True grabModeAsync grabModeAsync
spawn "~/ScriptsVcs/hideTint2.sh"
myHook :: Event -> X All
myHook e = do
case e of
ke#(KeyEvent _ _ _ _ _ _ _ _ _ _ _ _ _ _ _) -> do
if ev_keycode ke == 134
then if ev_state ke == 0
then do
-- key has been pressed
spawn "~/ScriptsVcs/showTint2.sh"
else do
spawn "~/ScriptsVcs/hideTint2.sh"
else pure ()
_ -> pure ()
pure $ All True
The above is an example. Do take note that a 'key release' could occur with a modifier key (ev_state).