# $Id: ctcomp.tcl 1969 2010-11-17 18:34:26Z sergei $
# "Chat text completion -- Tkabber plugin.
# Written by Konstantin Khomoutov <flatworm@users.sourceforge.net>
# See "lisence.terms" for details about distribution.
# Consult README for the information and usage guidelines.

option add *Chat.textCompletionForeground    black   widgetDefault
option add *Chat.textCompletionBackground    pink    widgetDefault

package require msgcat

namespace eval ctcomp {
    ::msgcat::mcload [file join [file dirname [info script]] msgs]
    if {![::plugins::is_registered ctcomp]} {
	::plugins::register ctcomp \
	    -namespace [namespace current] \
	    -source [info script] \
	    -description [::msgcat::mc "Whether the Chat text completion plugin is loaded."] \
	    -loadcommand [namespace code load] \
	    -unloadcommand [namespace code unload]
	return
    }
}

proc ctcomp::load {} {
    variable options
    set options(pattern) {\m%s\w+\M}

    bind_events
    bind_tags

    hook::add open_chat_post_hook  [namespace current]::prepare
    hook::add close_chat_post_hook [namespace current]::cleanup

    foreach chatid [chat::opened] {
	prepare $chatid
    }
}

proc ctcomp::unload {} {
    foreach chatid [chat::opened] {
	unprepare $chatid
    }

    hook::remove open_chat_post_hook  [namespace current]::prepare
    hook::remove close_chat_post_hook [namespace current]::cleanup

    unbind_tags
    unbind_events

    variable options
    unset options
}

proc ctcomp::bind_events {} {
    event add <<ChatTextCompNext>>    <Control-n>
    event add <<ChatTextCompNext>>    <Alt-slash>
    event add <<ChatTextCompNext>>    <Meta-slash>
    event add <<ChatTextCompPrev>>    <Control-p>
    event add <<ChatTextCompAccept>>  <Return>
    event add <<ChatTextCompCancel>>  <Escape>
    event add <<ChatTextCompMenu>>    <Alt-Control-slash>
    event add <<ChatTextCompMenu>>    <Meta-Control-slash>
}

proc ctcomp::unbind_events {} {
    event delete <<ChatTextCompNext>>    <Control-n>
    event delete <<ChatTextCompNext>>    <Alt-slash>
    event delete <<ChatTextCompNext>>    <Meta-slash>
    event delete <<ChatTextCompPrev>>    <Control-p>
    event delete <<ChatTextCompAccept>>  <Return>
    event delete <<ChatTextCompCancel>>  <Escape>
    event delete <<ChatTextCompMenu>>    <Alt-Control-slash>
    event delete <<ChatTextCompMenu>>    <Meta-Control-slash>
}

proc ctcomp::bind_tags {} {
    bind ChatTextCompInactive <<ChatTextCompNext>> [namespace code {
	if {[matches in %W]} {
	    activate %W
	    match first next in %W
	}
	break
    }]
    bind ChatTextCompInactive <<ChatTextCompPrev>> [namespace code {
	if {[matches in %W]} {
	    activate %W
	    match first prev in %W
	}
	break
    }]
    bind ChatTextCompInactive <<ChatTextCompMenu>> [namespace code {
	if {[matches in %W]} {
	    show_matches in %W
	    reset_state %W
	}
	break
    }]

    bind ChatTextCompActive <<ChatTextCompNext>>   [namespace code {
	match next next in %W
	break
    }]
    bind ChatTextCompActive <<ChatTextCompPrev>>   [namespace code {
	match next prev in %W
	break
    }]
    bind ChatTextCompActive <<ChatTextCompAccept>> [namespace code {
	accept %W
	deactivate %W
	break
    }]
    bind ChatTextCompActive <<ChatTextCompCancel>> [namespace code {
	cancel %W
	deactivate %W
	break
    }]
    bind ChatTextCompActive <Key> [namespace code {
	accept %W
	deactivate %W
    }]
}

proc ctcomp::unbind_tags {} {
    bind ChatTextCompInactive <<ChatTextCompNext>> {}
    bind ChatTextCompInactive <<ChatTextCompPrev>> {}
    bind ChatTextCompInactive <<ChatTextCompMenu>> {}
    bind ChatTextCompActive <<ChatTextCompNext>>   {}
    bind ChatTextCompActive <<ChatTextCompPrev>>   {}
    bind ChatTextCompActive <<ChatTextCompAccept>> {}
    bind ChatTextCompActive <<ChatTextCompCancel>> {}
    bind ChatTextCompActive <Key> {}
}

proc ctcomp::initialize iw {
    set btags [bindtags $iw]
    set ix [lsearch -exact $btags $iw]
    bindtags $iw [linsert $btags $ix ChatTextCompInactive]

    reset_state $iw
}

proc ctcomp::deinitialize iw {
    set btags [bindtags $iw]
    delete_from_list btags ChatTextCompInactive
    if {[delete_from_list btags ChatTextCompActive]} {
	cancel $iw
    }
    bindtags $iw $btags
}

proc ctcomp::delete_from_list {listVar elem} {
    upvar 1 $listVar L
    set ix [lsearch -exact $L $elem]
    if {$ix >= 0} {
	set L [lreplace $L $ix $ix]
	return 1
    } else {
	return 0
    }
}

proc ctcomp::activate iw {
    variable $iw
    upvar 0 $iw state

    set btags [bindtags $iw]
    set ix [lsearch -exact $btags ChatTextCompInactive]
    bindtags $iw [lreplace $btags $ix $ix ChatTextCompActive]

    hook::run chat_text_completion_start_hook $state(chatid) $state(what)
}

proc ctcomp::deactivate iw {
    variable $iw
    upvar 0 $iw state

    set btags [bindtags $iw]
    set ix [lsearch -exact $btags ChatTextCompActive]
    bindtags $iw [lreplace $btags $ix $ix ChatTextCompInactive]

    hook::run chat_text_completion_end_hook $state(chatid)

    reset_state $iw
}

proc ctcomp::prepare {chatid args} {
    set iw [chat::input_win $chatid]

    variable $iw
    upvar 0 $iw state
    set state(chatid) $chatid

    initialize $iw
}

proc ctcomp::unprepare {chatid} {
    set iw [chat::input_win $chatid]
    deinitialize $iw
    delete_state $iw
}

# NOTE This proc is called *after* the chat window is destroyed,
# by the means of the close_chat_post_hook hook.
# Getting the input window's name can be considered a hack
# as there's no implied guarantee that this name can be obtained
# and/or will have sensible meaning after the chat is closed.
proc ctcomp::cleanup {chatid} {
    set iw [chat::input_win $chatid]
    delete_state $iw
}

proc ctcomp::delete_state {iw} {
    variable $iw
    unset $iw
}

proc ctcomp::reset_state iw {
    variable $iw
    upvar 0 $iw state

    set state(matches) [list]
    set state(last)    ""
    set state(what)    ""
}

proc ctcomp::accept iw {
    $iw tag remove ctcomp/submatch comp_start comp_end
    $iw mark unset comp_start
    $iw mark unset comp_end
}

proc ctcomp::cancel iw {
    $iw delete comp_start comp_end
    $iw mark unset comp_start
    $iw mark unset comp_end
}

proc ctcomp::pattern what {
    variable options

    format $options(pattern) [string map {
	\\  \\\\
	[   \\[
	]   \\]
	\{  \\\{
	\}  \\\}
	(   \\(
	)   \\)
	$   \\$
	.   \\.
	*   \\*
	?   \\?
    } $what]
}

proc ctcomp::matches {"in" iw} {
    variable $iw
    upvar 0 $iw state
    upvar 0 state(what)    what
    upvar 0 state(matches) matches

    set what [word from $iw]
    if {[string length $what] == 0} { return false }

    set matches [get_matches for $what in $iw]
    if {[llength $matches] == 0} {
	show info $iw "No match for $what"
	return false
    }

    return true
}

proc ctcomp::startOfPreviousWord {str start} {
    if {[string equal $start end]} {
	set start [string length $str]
    }
    if {[regexp -indices {\m(\w+)\W*$} \
	    [string range $str 0 [expr {$start - 1}]] -> word]} {
	return [lindex $word 0]
    }
    return -1
}

proc ctcomp::word {"from" t} {
    set from [tk::TextPrevPos $t insert \
	[namespace current]::startOfPreviousWord]
    $t get $from insert
}

proc ctcomp::get_matches {"for" what "in" iw} {
    variable $iw
    upvar 0 $iw state
    upvar 0 state(chatid) chatid

    set completions [concat \
	[get_text_matches for $what in [chat::chat_win $chatid]] \
	[get_text_matches for $what in $iw]]

    hook::run chat_text_completion_matches_hook \
	$chatid $what #[info level] completions

    lsort -dictionary -unique $completions
}

proc ctcomp::get_text_matches {"for" what "in" t} {
    set pos 1.0
    set matches [list]

    while 1 {
	set at [$t search -count len -regexp [pattern $what] $pos end]
	if {$at == {}} break

	lappend matches [$t get $at "$at + $len chars"]

	set pos [$t index "$at + 1 char"]
    }

    set matches
}

proc ctcomp::last L {
    expr {[llength $L] - 1}
}

proc ctcomp::getopt {iw opt} {
    variable $iw
    upvar 0 $iw state

    option get [chat::winid $state(chatid)] $opt Chat
}

proc ctcomp::tail {what match} {
    string range $match [string length $what] end
}

proc ctcomp::match {seq dir "in" iw} {
    variable $iw
    upvar 0 $iw state
    upvar 0 state(what)    what
    upvar 0 state(matches) matches
    upvar 0 state(last)    last

    switch -- $seq {
	first {
	    switch -- $dir {
		next { set last 0 }
		prev { set last [last $matches] }
	    }
	    $iw mark set comp_start insert
	    $iw mark gravity comp_start left
	}
	next {
	    advance to $dir in $iw
	    $iw delete comp_start comp_end
	}
    }

    set submatch [tail $what [lindex $matches $last]]

    $iw tag configure ctcomp/submatch \
	-foreground [getopt $iw textCompletionForeground] \
	-background [getopt $iw textCompletionBackground]

    $iw insert comp_start $submatch ctcomp/submatch
    $iw mark set comp_end insert
    $iw mark gravity comp_end right
}

proc ctcomp::advance {"to" where "in" iw} {
    variable $iw
    upvar 0 $iw state
    upvar 0 state(last)    last
    upvar 0 state(matches) matches

    set end [last $matches]

    switch -- $where {
	next {
	    incr last
	    if {$last > $end} {
		set last 0
		wraparound in $iw
	    }
	}
	prev {
	    incr last -1
	    if {$last < 0} {
		set last $end
		wraparound in $iw
	    }
	}
    }
}

proc ctcomp::wraparound {"in" iw} {
    show info $iw "Wrapped around"
}

proc ctcomp::show_matches {"in" iw} {
    set m $iw.matches
    if {![winfo exists $m]} {
	menu $iw.matches -tearoff no -postcommand [list \
	    [namespace current]::repopulate_matches_menu $iw $m]
    }

    lassign [lrange [$iw bbox insert] 0 1] x y
    set x [expr {[winfo rootx $iw] + $x}]
    set y [expr {[winfo rooty $iw] + $y}]
    tk_popup $m $x $y 0
}

proc ctcomp::repopulate_matches_menu {iw m} {
    variable $iw
    upvar 0 $iw state
    upvar 0 state(what) what

    $m delete 0 end

    set i 0
    foreach match $state(matches) {
	if {[incr i] > 20} break
	$m add command -label $match -command [list \
	    [namespace current]::menu_insert_match $iw [tail $what $match]]
    }

    hook::run chat_text_completion_menu_hook $state(chatid) $state(what) $m
}


proc ctcomp::menu_insert_match {iw tail} {
    variable $iw

    $iw insert insert $tail
}

# $type should be either "info" or "error"
proc ctcomp::show {type iw msg} {
    variable $iw
    upvar 0 $iw state
    upvar 0 state(chatid) chatid

    set jid [chat::get_jid $chatid]
    set cw [chat::chat_win $chatid]

    chat::add_message $chatid $jid $type $msg {}
}

# vim:ts=8:sw=4:sts=4:noet
