172 lines
4.5 KiB
Fennel
172 lines
4.5 KiB
Fennel
(local { : Gtk } (require :lgi))
|
|
(local { : view } (require :fennel))
|
|
|
|
(local commands {})
|
|
|
|
(local Buffer (require :buffer))
|
|
|
|
(fn by-pairs [a]
|
|
(let [iter (fn [_ a]
|
|
(match a
|
|
[k v & rest] (values rest k v)
|
|
_ nil))]
|
|
(values iter a a)))
|
|
|
|
(fn define-command [name function ordered-params]
|
|
;; required parameter names and default arguments
|
|
(let [param-names (icollect [_ name val (by-pairs ordered-params)]
|
|
name)
|
|
params (collect [_ name val (by-pairs ordered-params)]
|
|
(values name val))
|
|
v {: name
|
|
: function
|
|
: param-names
|
|
: params}]
|
|
(tset commands name v)))
|
|
|
|
(define-command
|
|
"quit-browser"
|
|
#(Gtk.main_quit) [])
|
|
|
|
(define-command
|
|
"visit-location"
|
|
(fn [{:url url :buffer buffer}]
|
|
(let [b (Buffer.find buffer)] (: b :visit url)))
|
|
[:buffer (fn [f] f.buffer.name)
|
|
:url #(do "http://www.example.com")
|
|
])
|
|
|
|
(fn find-command [name]
|
|
(. commands name))
|
|
|
|
(local default-state {
|
|
:active false
|
|
:command nil
|
|
:collected-params {}
|
|
:this-param nil
|
|
})
|
|
|
|
(var state default-state)
|
|
(fn reset-state []
|
|
(set state default-state))
|
|
|
|
(fn next-param [command params]
|
|
(accumulate [v nil
|
|
_ k (ipairs command.param-names)
|
|
&until v]
|
|
(if (. params k) nil k)))
|
|
|
|
(fn invoke-command [command params]
|
|
(command.function params))
|
|
|
|
(fn next-action [state input-string]
|
|
(let [state-for-next-param
|
|
(fn [c params]
|
|
(match (next-param c params)
|
|
k1 {
|
|
:command c
|
|
:this-param k1
|
|
:collected-params params
|
|
:active true
|
|
}
|
|
_ (do (invoke-command c params) {:active false})))]
|
|
|
|
(match state
|
|
{:active false} state
|
|
|
|
{:command nil}
|
|
(match (find-command input-string)
|
|
{: name : params &as c}
|
|
(state-for-next-param c {})
|
|
|
|
nil
|
|
{
|
|
:active false
|
|
:error (.. "can't find command " input-string)
|
|
})
|
|
|
|
{:command c :this-param k :collected-params p}
|
|
(do
|
|
(tset p k input-string)
|
|
(state-for-next-param c p))
|
|
|
|
{:command c :this-param nil :collected-params p}
|
|
(do
|
|
(state-for-next-param c p))
|
|
|
|
_ (do (print "unexpected state " (view state))
|
|
state)
|
|
)))
|
|
|
|
(fn on-input [self str]
|
|
(let [s (next-action self.state str)
|
|
param (if s.active (. (. s.command :params) s.this-param))]
|
|
(set self.state s)
|
|
{
|
|
:active s.active
|
|
:error s.error
|
|
:prompt (if s.active (or s.this-param "Command?" "") "")
|
|
:default (and param (param self.frame))
|
|
}))
|
|
|
|
(fn update-widget-state [{ : entry : prompt} result]
|
|
(set prompt.label (or result.prompt ""))
|
|
(set entry.sensitive result.active)
|
|
(set entry.text (or result.default result.error "")))
|
|
|
|
(fn activate [{: state : entry : prompt}]
|
|
(tset state :active true)
|
|
(set entry.sensitive true)
|
|
(set entry.text "")
|
|
(set prompt.label (or state.this-param "Command" ""))
|
|
(entry:grab_focus)
|
|
state)
|
|
|
|
(fn invoke-interactively [self name params]
|
|
(let [c (find-command name)
|
|
supplied-params (collect [k v (pairs params)]
|
|
(values k (v self.frame)))
|
|
s {
|
|
:active true
|
|
:command c
|
|
:collected-params supplied-params
|
|
}]
|
|
(set self.state s)
|
|
(let [r (self:on-input nil)]
|
|
(update-widget-state self r)
|
|
(self.entry:grab_focus)
|
|
r)))
|
|
|
|
(fn new-commander [frame]
|
|
(let [entry (Gtk.Entry {:sensitive false })
|
|
prompt (Gtk.Label { :label ""})
|
|
box (Gtk.Box {
|
|
:orientation Gtk.Orientation.HORIZONTAL
|
|
})
|
|
self {
|
|
:state default-state
|
|
: activate
|
|
:active? (fn [self] self.state.active)
|
|
: on-input
|
|
: invoke-interactively
|
|
: entry
|
|
:widget box
|
|
: prompt
|
|
: frame
|
|
}]
|
|
(box:pack_start prompt false false 15)
|
|
(box:pack_start entry true true 5)
|
|
(tset entry :on_activate
|
|
(fn [event]
|
|
(let [result (self:on-input event.text)]
|
|
(set prompt.label (or result.prompt ""))
|
|
(set entry.sensitive result.active)
|
|
(set entry.text (or result.default result.error "")))))
|
|
self))
|
|
|
|
|
|
{
|
|
:commander new-commander
|
|
: define-command
|
|
}
|