dunlin/command.fnl

(local { : Gtk  } (require :lgi))
(local { : view } (require :fennel))
(local lume (require :lume))

(local commands {})

(local Buffer (require :buffer))

(fn define-command [name ordered-params function]
  ;; required parameter names and default arguments
  (let [param-names (icollect [_ [name] (pairs ordered-params)] name)
        params (collect [_ [name completer default] (pairs ordered-params)]
                 (values name {: completer : default}))
        v {: name
           : function
           : param-names
           : params}]
    (tset commands name v)))

(fn completion [{: widget : text : value }]
  (let [value (or value (assert text "must have text"))]
    {
     :widget (or widget (Gtk.Button { :label text }))
     : text
     : value
     }))

(define-command
 "quit-browser"
 []
 #(Gtk.main_quit))


(define-command
 "switch-to-buffer"
 [[:buffer
   #(lume.map (Buffer.match $1) #(completion { :text $1.name :value $1 }))
   #(. (Buffer.next $1.buffer) :name)]
  ]
 (fn [{:frame frame :buffer buffer}]
   (frame:show-buffer buffer)))

(define-command
 "visit-location"
 [[:buffer
   #(lume.map (Buffer.match $1) #(completion { :text $1.name :value $1 }))
   #$1.buffer.name]
  [:url
   (fn [term]
     (if (> (# term) 2)
         (icollect [v (_G.history:find-distinct term)]
           (let [label (.. v.url " " (or v.title ""))]
             (completion { :text v.url
                           :widget (Gtk.Button { : label })
                           :value v.url
                           })))
         []))
   #($1.buffer:location)]
  ]
 (fn [{:url url :buffer buffer}]
   (buffer:visit url)))

(define-command
 "back"
 [[:buffer
   #(lume.map (Buffer.match $1) #(completion { :text $1.name :value $1 }))
   #$1.buffer.name]]
 (fn [{: buffer}] (buffer:back)))

(fn find-command [name]
  (. commands name))

(local default-state {
                      :active false
                      :command nil
                      :collected-params {}
                      :this-param nil
                      })

(fn next-param [command params]
  (accumulate [v nil
               _ k (ipairs command.param-names)
               &until v]
    (if (. params k) nil k)))

(fn next-action [self input-string]
  (let [state self.state
        state-for-next-param
        (fn [c params]
          (match (next-param c params)
            k1 {
                :command c
                :this-param k1
                :collected-params params
                :active true
                }
            _ (let [params (lume.extend {} {:frame self.frame} params)]
                (c.function 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}
      (let [{ : completer}  (. c.params k)
            vals (completer input-string)
            chosen (lume.match vals #(= $1.text input-string))]
        (assert chosen (view { : vals : input-string }))
        (tset p k chosen.value)
        (state-for-next-param c p))

      {:command c :this-param nil :collected-params p}
      (state-for-next-param c p)

      _ (do (print "unexpected state " (view state))
            state)
      )))

(fn on-input-finished [self str]
  (let [s (next-action self 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.default self.frame))
     }))

(fn update-widget-state [{ : widget : entry : completions-widget : prompt} result]
  (set prompt.label (or result.prompt ""))
  (set entry.sensitive result.active)
  (if (not result.active)
      (completions-widget:hide))
  (set entry.text (or result.default result.error ""))
  (when widget.parent
    (widget.parent:set_visible_child_name
     (if result.active "commander" "echo-area"))))

(fn on-input [self str]
  (let [parent self.completions-widget
        set-completions
        (fn [completions]
          (parent:foreach #(parent:remove $1))
          (each [_ c (pairs completions)]
            (parent:add
             (doto c.widget
               (tset :on_clicked
                     #(update-widget-state
                       self
                       (self:on-input-finished c.text))))))
          (parent:show_all))]
    (match self.state
      {:command c :this-param param-name}
      (let [{ : completer}  (. c.params param-name)]
        (set-completions (completer str)))

      {:command nil}
      (set-completions
       (collect [k _ (pairs  commands)]
         (if (= (k:find str 1 true) 1) (values k k)))))))

(fn activate [{: state : entry : prompt &as self}]
  (tset state :active true)
  (update-widget-state
   self
   {:active true
    :prompt (or state.this-param  "Command" "")
    })
  (entry:grab_focus)
  state)

(fn deactivate [{: state : entry : prompt &as self}]
  (doto state
    (lume.clear)
    (tset :active false))
  (update-widget-state self {:active false}))

(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-finished 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.VERTICAL
                      })
        hbox (Gtk.Box {
                      :orientation Gtk.Orientation.HORIZONTAL
                      })
        completions (Gtk.FlowBox)
        self {
              :state default-state
              : activate
              : deactivate
              :active? (fn [self] self.state.active)
              : on-input
              : on-input-finished
              : invoke-interactively
              : entry
              :widget box
              : prompt
              : frame
              :completions-widget completions
              }]
    (hbox:pack_start prompt false false 15)
    (hbox:pack_start entry true true 5)
    (box:pack_start hbox true false 0)
    (box:pack_start completions true true 0)
    (tset entry :on_changed
          (fn [event]
            (self:on-input event.text)))
    (tset entry :on_activate
          (fn [event]
            (let [result (self:on-input-finished event.text)]
              (update-widget-state self result))))
    self))


{
 :commander new-commander
 : define-command
 : completion
 }