#
# Copyright (c) 2012-2014,2017,2021-2022 LAAS/CNRS
# All rights reserved.
#
# Permission to use, copy, modify, and distribute this software for any purpose
# with or without   fee is hereby granted, provided   that the above  copyright
# notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH
# REGARD TO THIS  SOFTWARE INCLUDING ALL  IMPLIED WARRANTIES OF MERCHANTABILITY
# AND FITNESS. IN NO EVENT SHALL THE AUTHOR  BE LIABLE FOR ANY SPECIAL, DIRECT,
# INDIRECT, OR CONSEQUENTIAL DAMAGES OR  ANY DAMAGES WHATSOEVER RESULTING  FROM
# LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR
# OTHER TORTIOUS ACTION,   ARISING OUT OF OR IN    CONNECTION WITH THE USE   OR
# PERFORMANCE OF THIS SOFTWARE.
#
#                                            Anthony Mallet on Sun Apr  8 2012
#

namespace eval genomix::pmt {
  variable eltcl [expr {![catch {package present eltclsh}]}]
  variable interrupt ...


  # --- iscanarg -----------------------------------------------------------
  #
  proc iscanarg { kind prompt defval } {
    variable eltcl
    variable interrupt

    if {$defval != ""} { append prompt " ($defval)" }

    while 1 {
      if {$eltcl} {
        switch -- [lindex $kind 0] {
          {enum} {
            set old $::el::completionPatterns
            set ::el::completionPatterns \
                [list [list {} "c {} [list [lrange $kind 1 end]]"]]
          }
        }

        set s [catch {el::gets "$prompt > "} input]

        switch -- [lindex $kind 0] {
          {enum} { set ::el::completionPatterns $old }
        }

        if {$s} { error $input }
      } else {
        puts -nonewline "$prompt > "
        flush stdout
        set s [catch {gets stdin input} n]
        if {$s} { error $input }
        if {$n < 0} { error "user abort" }
      }

      # user might want default value or interrupt
      if { $input == "" } { set input $defval }
      if { $input == $interrupt } { return $interrupt }

      # check input validity
      set s [catch {
        switch -glob -- $kind {
          {boolean} {
            set input [expr {[uplevel #0 expr [list $input]]?1:0}]
          }
          {octet} {
            set input [expr {[uplevel #0 expr [list $input]]}]
            if {$input < -128 || $input > 127} {
              error "argument out of range, expecting $kind"
            }
          }
          {short} {
            set input [expr {[uplevel #0 expr [list $input]]}]
            if {$input < -32768 || $input > 32767} {
              error "argument out of range, expecting $kind"
            }
          }
          {unsigned short} {
            set input [expr {[uplevel #0 expr [list $input]]}]
            if {$input < 0 || $input > 65535} {
              error "argument out of range, expecting $kind"
            }
          }
          {long} {
            set input [expr {[uplevel #0 expr [list $input]]}]
            if {$input < -2**31 || $input > 2**31-1} {
              error "argument out of range, expecting $kind"
            }
          }
          {unsigned long} {
            set input [expr {[uplevel #0 expr [list $input]]}]
            if {$input < 0 || $input > 2**32-1} {
              error "argument out of range, expecting $kind"
            }
          }
          {long long} {
            set input [expr {[uplevel #0 expr [list $input]]}]
            if {$input < -2**63 || $input > 2**63-1} {
              error "argument out of range, expecting $kind"
            }
          }
          {unsigned long long} {
            set input [expr {[uplevel #0 expr [list $input]]}]
            if {$input < 0 || $input > 2**64-1} {
              error "argument out of range, expecting $kind"
            }
          }
          {float} - {double} {
            set input [expr {[uplevel #0 expr [list $input]]}]
          }
          {char} {
            set input [string index [uplevel #0 subst [list $input]] 0]
          }
          {string} {
            set input [uplevel #0 subst [list $input]]
            if {[lindex $kind 1] != ""} {
              if {[string bytelength $input] >= [lindex $kind 1]} {
                error "string too long"
              }
            }
          }
          {enum *} {
            set input [string trim [uplevel #0 subst [list $input]]]
            if { [lsearch [lrange $kind 1 end] $input] < 0 } {
              error "expecting one of: [join [lrange $kind 1 end] {, }]"
            }
          }
        }
      } m]

      if {$s} {
        puts "error: $m"
        continue
      }

      break
    }

    return $input
  }


  # --- iscandict ----------------------------------------------------------
  #
  proc iscandict { indent name format meta } {
    variable interrupt

    set items [dict create]
    dict with meta {}
    dict with format {}

    set prompt "$indent$kind $name"
    if {[info exists length]} { append prompt "\[$length\]" }
    if {[info exists doc]} { append prompt ": $doc" }
    if {![info exists default]} { set default {} }

    switch -- $kind {
      struct {
        puts $prompt
        set arg [dict create]
        dict for {p f} $type {
          if {[catch {dict get $items $p} m]} {
            set m [dict create]
          }
          set a [iscandict "$indent| " "$name.$p" $f $m]
          if {$a == $interrupt} break
          dict set arg $p $a
        }
      }

      union {
        puts $prompt
        set arg [dict create]
        set a [iscandict "$indent| " "$name.d" $discr {}]
        if {$a == $interrupt} break
        dict set arg d $a
        dict for {p v} $cases {
          if {$a in $v} break;
        }
        set f [dict get $type $p]
        if {[catch {dict get $items $p} m]} {
          set m [dict create]
        }
        set a [iscandict "$indent| " "$name.u.$p" $f $m]
        if {$a == $interrupt} break
        dict set arg u [dict create $p $a]
      }

      array - sequence {
        puts $prompt
        set arg [dict create]
        if {![info exists length]} {
          set length [iscanarg "unsigned long" "$prompt length" 0]
          if {$length == $interrupt} return $arg
        }
        for {set i 0} {$i < $length} {incr i} {
          if {[catch {dict get $items $i} m]} {
            set m [dict create]
          }
          set a [iscandict "$indent| " "$name\[$i\]" $type $m]
          if {$a == $interrupt} break
          dict set arg $i $a
        }
      }

      optional {
        puts $prompt
        set arg [list]
        set present [iscanarg "boolean" "$indent| present" 1]
        if {$present == $interrupt || !$present} return $arg
        set m [dict create items $items default $default]
        set value [iscandict "$indent| " $name $type $m]
        if {$value == $interrupt} break
        set arg $value
      }

      default {
        if {[info exists length]} { lappend kind $length }
        if {[info exists values]} { lappend kind {*}[dict values $values] }
        set arg [iscanarg $kind $prompt $default]
      }
    }

    return $arg
  }


  # --- iscanargs ----------------------------------------------------------
  #
  proc iscanargs { input meta } {
    variable interrupt

    set arg [dict create]
    dict for {p f} $input {
      if {[catch {dict get $meta $p} m]} {
        set m [dict create]
      }
      set a [iscandict "" $p $f $m]
      if {$a == $interrupt} break
      dict set arg $p $a
    }

    return $arg
  }

  # --- args2dict ----------------------------------------------------------
  #
  proc args2dict { format args& } {
    upvar ${args&} args

    dict with format {}
    switch -- $kind {
      struct {
        set arg [dict create]
        dict for {p f} $type {
          if {![llength $args]} break
          dict set arg $p [args2dict $f args]
        }
      }

      union {
        set arg [dict create]
        dict set arg d [args2dict $discr args]

        if {[llength $args]} {
          dict for {p v} $cases {
            if {[dict get $arg d] in $v} break;
          }
          set f [dict get $type $p]
          dict set arg u [dict create $p [args2dict $f args]]
        }
      }

      array - sequence {
        set arg [dict create]
        if {[llength $args]} {
          set args [lassign $args a]
          set l [llength $a]
          for {set i 0} {$i < $l} {incr i} {
            dict set arg $i [args2dict $type a]
          }
        }
      }

      optional {
        if {![llength [lindex $args 0]]} {
          set args [lassign $args arg]
        } else {
          set arg [args2dict $type args]
        }
      }

      default {
        set args [lassign $args arg]
      }
    }

    return $arg
  }


  # --- dict2json ----------------------------------------------------------
  #
  proc dict2json { arg data format } {
    dict with format {}

    switch -- $kind {
      struct {
        # check missing arguments
        if {[catch {dict size $data}]} {
          error "$kind $arg expects dictionary data"
        }
        dict for {p v} [dict get $format type] {
          if {[catch {dict get $data $p}]} {
            error "missing value for argument $arg.$p"
          }
        }

        # build json
        set json [list]
        dict for {p v} $data {
          if {[catch {dict get $format type $p} f]} {
            error "unknown argument $arg.$p"
          }
          lappend json [subst {"$p":[dict2json "$arg.$p" $v $f]}]
        }
        set json "{[join $json ,]}"
      }

      union {
        # check missing arguments
        if {[catch {dict size $data}]} {
          error "$kind $arg expects dictionary data"
        }
        if {[catch {dict get $data d} d]} {
          error "missing value for discriminator $arg.d"
        }
        if {[catch {dict get $data u} u]} {
          error "missing value for union $arg.u"
        }

        # build json
        set json [list]
        set d [dict2json d $d [dict get $format discr]]
        dict for {p v} $u {
          if {[catch {dict get $format type $p} f]} {
            error "unknown argument $arg.$p"
          }
          lappend json [subst {"$p":[dict2json "$arg.$p" $v $f]}]
        }
        set json "{\"d\":$d, \"u\":{[join $json ,]}}"
      }

      array - sequence {
        # check missing arguments
        if {[catch {dict size $data} s]} {
          error "$kind $arg expects compound data"
        }
        if {[info exists length]} { set l $length } else { set l $s }
        for {set i 0} {$i<$l} {incr i} {
          if {[catch {dict get $data $i}]} {
            error "missing value for index $i of argument $arg"
          }
        }

        # build json
        set json [list]
        dict for {p v} $data {
          if {![string is integer -strict $p] || $p < 0} {
            error "bad index $p in $kind $arg"
          }
          if {[info exists length]} {
            if {$p >= $length} {
              error "element $p in $kind $arg out of range ($length max)"
            }
          }
          set f [dict get $format type]
          lappend json [subst {"$p":[dict2json "$arg\[$p\]" $v $f]}]
        }
        set json "{[join $json ,]}"
      }

      optional {
        if {[llength $data] == 0} {
          set json null
        } else {
          set json [dict2json "$arg" $data [dict get $format type]]
        }
      }

      char - string {
        if {[info exists length]} {
          if {[string bytelength $data] >= $length} {
            error "$kind $arg too long ($length max): $data"
          }
        }
        set json [subst {"[string map [list \" \\\" \\ \\\\] $data]"}]
      }

      enum {
        set v [dict get $format values]
        if {[lsearch $v $data] < 0} {
          if {[lsearch -glob $v *::$data] < 0} {
            error [concat "bad value for $kind $arg: $data " \
                       "(should be one of [join $v {, }])"]
          }
        }
        set json [subst {"$data"}]
      }

      double - float {
        if {![string is double -strict $data]} {
          error "bad value for $kind $arg: $data"
        }
        set json [expr {$data}]
      }

      default {
        if {![string is integer -strict $data]} {
          error "bad value for $kind $arg: $data"
        }
        set json [expr {$data}]
      }
    }

    return $json
  }


  # --- arg2json -----------------------------------------------------------
  #
  proc arg2json { fmt data defarg format } {
    # create argument dictionary if needed
    if {$fmt == "flat"} {
      set args $data
      set data [dict create]
      dict for {p v} $format {
        if {![llength $args]} break
        dict set data $p [args2dict $v args]
      }

      if {[llength $args]} {
        error "too many arguments: $args"
      }
    }

    # merge defaults
    foreach {k v} $defarg {
      if {![catch {dict get $format [lindex $k 0]}] &&
          [catch {dict get $data {*}$k}]} {
        dict set data {*}$k $v
      }
    }

    # check missing arguments
    dict for {p v} $format {
      if {[catch {dict get $data $p}]} {
        error "missing value for argument $p"
      }
    }

    # build json string
    set json [list]
    dict for {p v} $data {
      if {[catch {dict get $format $p} f]} {
        error "unknown argument $p"
      }
      lappend json [subst {"$p":[dict2json $p $v $f]}]
    }
    return "{[join $json ,]}"
  }


  # --- meta2defarg --------------------------------------------------------
  #
  proc meta2defarg { meta } {
    set defarg [list]
    dict for {p v} $meta {
      if {![catch {dict get $v default} d]} {
        lappend defarg $p $d
      } elseif {![catch {dict get $v items} items]} {
        foreach {k v} [meta2defarg $items] {
          lappend defarg [linsert $k 0 $p] $v
        }
      }
    }
    return $defarg
  }


  # --- dict2doc -----------------------------------------------------------
  #
  proc dict2doc { indent name format meta } {
    variable interrupt

    set items [dict create]
    dict with meta {}
    dict with format {}

    set prompt "\n$indent$kind"
    if {$name != ""} { append prompt " $name" }
    if {[info exists length]} { append prompt "\[$length\]" }
    if {[info exists doc]} { append prompt ": $doc" }
    if {$kind != "optional"} {
      if {[info exists default]} { append prompt " ($default)" }
    }

    switch -- $kind {
      {struct} - {union} {
        dict for {p f} $type {
          if {[catch {dict get $items $p} m]} { set m [dict create] }
          append prompt [dict2doc "$indent| " "$name.$p" $f $m]
        }
      }

      array - sequence {
        append prompt [dict2doc "$indent| " "$name\[i\]" $type {}]
        dict for {i m} $items {
          append prompt [dict2doc "$indent| " "$name\[$i\]" $type $m]
        }
      }

      optional {
        set m [dict create]
        if {[info exists default]} { dict set m default $default }
        append prompt [dict2doc "$indent| " "" $type $m]
      }
    }

    return $prompt
  }


  # --- meta2doc -----------------------------------------------------------
  #
  proc meta2doc { input meta } {
    set doc ""
    dict for {p f} $input {
      if {[catch {dict get $meta $p} m]} { set m [dict create] }
      append doc [dict2doc "" $p $f $m]
    }

    return $doc
  }


  # --- mvwait -------------------------------------------------------------
  #
  # vwait for multiple vars with timeout support (and SIGINT aware with
  # eltclsh). Adapted from http://wiki.tcl.tk/1302
  #
  proc mvwait-trigger { id args } {
    variable mvwait-trigger
    set mvwait-trigger($id) $args
  }

  proc mvwait {timeout args} {
    variable mvwait-trigger
    variable mvwait-id
    variable eltcl

    # create trigger script that will cause vwait to fall thru
    set id "mvwait-[incr mvwait-id]"
    set trigger [namespace code [list mvwait-trigger $id]]

    # create trace to trip trigger and timeout if requested
    foreach var $args { uplevel 1 [list trace variable $var w $trigger] }
    if {$timeout > 0} { set timerid [after $timeout {*}$trigger -timeout] }
    if {$eltcl} { set sigint [signal INT [list {*}$trigger -interrupt]] }

    # wait
    vwait [namespace which -variable mvwait-trigger]($id)

    # cleanup
    foreach var $args { uplevel 1 [list trace vdelete $var w $trigger] }
    if [info exists timerid] { after cancel $timerid }
    if [info exists sigint] { signal INT $sigint }
    set r [set mvwait-trigger($id)]
    unset mvwait-trigger($id)

    switch -- $r {
      -timeout { error timeout }
      -interrupt { error interrupt }
    }
    return
  }
}
