#---------------------------------------------------------*-tcl-*------
#
#  psmenu.tcl
#   Framework for building Tk menu structure
#
#  Copyright (c) 2024, Peter Spjuth  (peter.spjuth@gmail.com)
#
#  Permission is granted to use this code under the same terms as
#  for the Tcl core code.
#
#----------------------------------------------------------------------
#  This is used as a Tcl Module. Use it like this:
#  ::tcl::tm::path add <path-to-dir-with-module>
#  package require psmenu
#  psmenu::psmenu . {
#      definitions...
#  }
#----------------------------------------------------------------------

package provide psmenu 1.1

namespace eval psmenu {
    namespace export psmenu
}

set psmenu::example {
    # All definition blocks are lists.
    # Thus \-newline are not strictly necessary.
    # For compactness, options are kept short
    # -ul  for -underline
    #          "&File"-syntax supported for label
    # -var for -variable
    #          Variable is initialised if not existing
    #          If used with cascade, store menu widget in var
    # -cfgvar  Store entryconfigure command in var
    # -cmd for -command
    #          command part is put through "subst"
    # -acc for -accelerator
    #          Will bind <Key-acc> to command unless -accelerator
    # -def for default value of -var
    #          checkbuttons default to default 0
    #          radiobuttons default to first value seen
    # if/else commands can be included
    package require psmenu
    psmenu::psmenu . {
        # Comments are ok
        # If an argument looks like a "body" this is a cascade
        "&File" {
            "&Copy Solver URL" -cmd copySolverUrl
            # Separator is --*
            --------------------
            "&Quit" -cmd exit
        }
        "&Config" {
            "&Rules" -var ::mooa {
                "Knight" -var ::ruleset(knight) -cmd changeRuleSet
                "King"   -var ::ruleset(king)   -cmd changeRuleSet
                "No Consecutive" -var ::ruleset(consecutive) -cmd changeRuleSet
                "Grid Size" -var mooo {
                    # TBD allow loops?
                    # Define a bunch of radiobuttons at once.
                    # Without -value it is same as label string
                    _Radio -var ::ruleset(gridsize) -cmd newGame -def 9 {
                        "8"  -value 8
                        "9"  -value 9
                        "10"
                    }
                    # Individual example
                    "6"  -value 6  -var ::ruleset(gridsize) -cmd newGame
                }
            }
            # checkbutton has a -var and possibly -cmd, -onvalue, -offvalue
            "Conflict Check" -var ::uiData(conflict) -cmd autoConflict
        }
    }
    # More calls with more cascades work
    psmenu::psmenu . {
        "&Debug" {
            "Reread &Source" -acc F1 -cmd _rs
        }
    }
}

##nagelfar syntax psmenu::PopEntry v
##nagelfar syntax tk::AmpMenuArgs x*

# Main call for psmenu. Some optional arguments are for internal use.
# Can be called with an existing menu, but then -top must be given.
##nagelfar syntax psmenu::psmenu x p* x
##nagelfar ignore does not match
proc psmenu::psmenu {top args} {
    set def [lindex $args end]
    set args [lrange $args 0 end-1]

    set opts(-top) ""
    set opts(-level) ""
    set opts(-level) ""
    set opts(-recursive) 0
    array set opts $args

    # Is given arg a toplevel or menu?
    if {$top eq "."} {
        set m .m
    } else {
        if {[winfo class $top] ne "Menu"} {
            set m $top.m
        } else {
            # A menu was given, assume -top
            set m $top
            set top $opts(-top)
        }
    }

    if {$opts(-recursive)} {
        # Locate a free window name for the menu, for internal call
        while {[winfo exists $m]} {
            if {[regexp {^(.*?)(\d+)$} $m -> prefix Index]} {
                incr Index
            } else {
                set prefix $m
                set Index 0
            }
            set m $prefix$Index
        }
    }
    # It might exist for a second user call
    if { ! [winfo exists $m]} {
        # Create
        menu $m -tearoff 0
    }

    if {$opts(-level) eq ""} {
        # Store initial level to handle scope when recursing cascades
        set opts(-level) [uplevel 1 info level]
    }
    if {$opts(-top) eq ""} {
        set opts(-top) $top
        $top configure -menu $m
    }

    # Comments in definition block
    set def [regsub -all -line {^\s*#.*$} $def ""]

    set state ""
    while {[llength $def] > 0} {
        #puts "Def length [llength $def]"; update
        set entry [PopEntry def]
        set label [lindex $entry 0]
        if {$label eq "_Radio"} {
            set options [lrange $entry 1 end-1]
            set body [lindex $entry end]
            set radioDef {}
            for {set t 0} {$t < [llength $body]} {incr t} {
                set label [lindex $body $t]
                if {[lindex $body $t+1] eq "-value"} {
                    incr t 2
                    set value [lindex $body $t]
                } else {
                    set value $label
                }
                lappend radioDef $label -value $value {*}$options
            }
            #puts "RADIO '$radioDef'"

            # Prepend
            set def [list {*}$radioDef {*}$def]
            # TBD FIXA
            continue
        }

        # Conditionals
        if {$label eq "if"} {
            # TBD support elseif
            set ifExpr [lindex $entry 1]
            set body   [lindex $entry 2]
            set elseBody [lindex $entry 4]
            set cond [uplevel \#$opts(-level) [list expr $ifExpr]]
            #puts "if expression '$ifExpr' = $cond"
            if {$cond} {
                # Prepend
                set def [list {*}$body {*}$def]
            } elseif {$elseBody ne ""} {
                set def [list {*}$elseBody {*}$def]
            }
            continue
        }

        # Recognise Cascade by even args "Name ?opts? Def"
        # An item will be "Name ?opts?", i.e odd
        if {[llength $entry] % 2 == 0} {
            # Cascade
            set options [lrange $entry 1 end-1]
            set body [lindex $entry end]
            # Recurse cascade defintion
            set cascade [psmenu $m {*}[array get opts] -recursive 1 $body]
            # Since -menu is last, processing below can assume that.
            lappend options -menu $cascade
        } else {
            set options [lrange $entry 1 end]
        }
        #puts "Label   '$label'"
        #puts "Options '$options'"
        # Figure out type
        if {[string match "-*" $label]} {
            set type separator
            set label ""
        } elseif {[dict exists $options -menu]} {
            set type "cascade"
        } elseif {[dict exists $options -value]} {
            set type radiobutton
        } elseif {[dict exists $options -var]} {
            set type checkbutton
        } else {
            set type command
        }
        # Process options
        set newOptions {}
        if {$label ne ""} {
            lappend newOptions -label $label
        }
        set doBind ""
        set command ""
        set value ""
        set variable ""
        set cfgvar ""
        set default 0
        foreach {opt val} $options {
            set val [uplevel \#$opts(-level) [list subst $val]]
            switch -- $opt {
                -ul - -underline {
                    lappend newOptions -underline $val
                }
                -var - -variable {
                    if {$type eq "cascade"} {
                        set variable $val
                    } else {
                        set variable $val
                        lappend newOptions -variable $val
                    }
                }
                -cfgvar {
                    set cfgvar $val
                }
                -cmd - -command {
                    set command $val
                    lappend newOptions -command $val
                }
                -acc {
                    lappend newOptions -accelerator $val
                    set doBind $val
                }
                -accelerator {
                    lappend newOptions -accelerator $val
                }
                -value {
                    lappend newOptions -value $val
                    set default $val
                }
                -offvalue {
                    lappend newOptions -offvalue $val
                    set default $val
                }
                -onvalue {
                    lappend newOptions -onvalue $val
                }
                -menu {
                    lappend newOptions -menu $val
                    if {$variable ne ""} {
                        uplevel \#$opts(-level) [list set $variable $val]
                    }
                }
                -def {
                    set default $val
                }
                default {
                    # Just let through
                    lappend newOptions $opt $val
                }
            }
        }

        if {$variable ne ""} {
            ##nagelfar ignore Non constant level
            upvar \#$opts(-level) $variable __vv
            if { ! [info exists __vv]} {
                set __vv $default
            }
        }

        # TK helper to handle & in label
        ::tk::AmpMenuArgs $m add $type {*}$newOptions

        if {$cfgvar ne ""} {
            set ix [$m index end]
            set tmp [list $m entryconfigure $ix]
            uplevel \#$opts(-level) [list set $cfgvar $tmp]
        }

        if {$doBind ne ""} {
            if {[regexp {^(.*)-(.*)$} $doBind -> pre post]} {
                if {$pre eq "Ctrl"} {
                    set pre "Control"
                }
                set doBind $pre-Key-$post
            } else {
                set doBind Key-$doBind
            }
            #puts "Binding '$doBind' '$command'"
            bind $opts(-top) <$doBind> $command
        }
    }

    return $m
}

# Extract one entry from definiton
proc psmenu::PopEntry {defName} {
    upvar 1 $defName def

    set result {}

    if {[lindex $def 0] eq "if"} {
        # TBD support elseif
        if {[lindex $def 0] eq "else"} {
            set result [lrange $def 0 4]
            set def [lrange $def 5 end]
        } else {
            set result [lrange $def 0 2]
            set def [lrange $def 3 end]
        }
        return $result
    }

    set state "label"
    set n -1
    foreach arg $def {
        incr n
        switch $state {
            "label" {
                lappend result $arg
                set state "option"
            }
            "option" {
                if {[string match "--*" $arg]} {
                    incr n -1
                    break
                } elseif {[string match "-*" $arg]} {
                    lappend result $arg
                    set state "value"
                } elseif {[regexp {^\s+.*\s+$} $arg] || $arg eq ""} {
                    # recognise body somehow
                    lappend result $arg
                    break
                } else {
                    # Must be next label
                    incr n -1
                    break
                }
            }
            "value" {
                lappend result $arg
                set state "option"
            }
        }
    }
    incr n
    set def [lrange $def $n end]
    return $result
}

if 0 {
    set mooo "Not set"
    console show
    package require Tk
    update
    wm geometry . 400x400
    update
    eval ${psmenu::example}
    puts "mooo $mooo"
    puts "mooa $mooa"
}
