#!/usr/bin/wish

package require Tk
tk appname shell.tcl
bind [winfo class .] <Destroy> exit

# create console window

destroy .shell
pack [frame .shell] -expand yes -fill both

grid [text .shell.t\
  -wrap none\
  -font "Monospace 10"\
  -yscrollcommand {.shell.v set}\
  -xscrollcommand {.shell.h set}]\
  [scrollbar .shell.v -orient vertical -command {.shell.t yview}]\
  -sticky news
grid [scrollbar .shell.h\
  -orient horizontal\
  -command {.shell.t xview}]\
  -sticky news
grid rowconfigure .shell 0 -weight 1
grid columnconfigure .shell 0 -weight 1

bind . <FocusIn> {focus .shell.t}

event add <<ToggleWrap>> <Escape><Key-space>

bind .shell.t <<ToggleWrap>> {
  if {[.shell.t cget -wrap] eq "none"} then {
    .shell.t configure -wrap char
    grid forget .shell.h
  } else {
    .shell.t configure -wrap none
    grid .shell.h -sticky news
  }
  after idle [list .shell.t see insert]
  break
}

bind .shell <<ToggleWrap>> [bind .shell.t <<ToggleWrap>>]
bind . <<ToggleWrap>> [bind .shell.t <<ToggleWrap>>]

after idle "event generate .shell.t <<ToggleWrap>>"

.shell.t tag configure prompt -foreground blue
.shell.t tag configure result -foreground green
.shell.t tag configure error -foreground red

bind .shell.t <Double-1> {
  if {[selectToClosingChar %W]} then break
}
bind .shell.t <Control-plus> {
  apply {win {lassign [$win cget -font] font size      
              $win configure -font [list $font [incr size 2]]}} %W
}
bind .shell.t <Control-minus> {
  apply {win {lassign [$win cget -font] font size
              if {$size >= 8} then {
                $win configure -font [list $font [incr size -2]]}}} %W
}
bind .shell.t <BackSpace> {
  if {[%W tag ranges sel] ne ""} then continue
  if {([%W get insert-1chars] eq " " &&
      "prompt" in [%W tag names insert-2chars]) ||
      "prompt" in [%W tag names insert-1chars]} then break
}
bind .shell.t <Left> {
  if {[apply {
        win {
          if {[$win tag ranges sel] ne ""} then {
            $win mark set insert sel.first
            $win tag remove sel 1.0 end
            return true
          } elseif {
            "prompt" in [$win tag names insert-1chars] ||
            "prompt" in [$win tag names insert-2chars]
          } then {
            lassign [$win tag prevrange prompt insert+1chars 1.0] start
            if {[$win compare $start != 1.0]} then {
              $win mark set insert $start-1chars
            }
            return true
          }
          return false
        }
      } %W]} then {
    %W see insert
    break
  }
}
bind .shell.t <Control-Left> continue
bind .shell.t <Shift-Left> continue
bind .shell.t <Delete> {
  if {[%W tag ranges sel] ne ""} then continue
  if {"prompt" in [%W tag names insert] ||
      ("prompt" in [%W tag names insert-1chars] &&
      [%W get insert] eq " ")  } then break
}
bind .shell.t <Right> {
  if {[%W tag ranges sel] ne ""} then {
    %W mark set insert sel.last
    %W tag remove sel 1.0 end
    break
  } elseif {"prompt" in [%W tag names insert+1chars]} then {
    %W mark set insert [lindex [%W tag nextrange prompt insert] end]+1chars
    break
  }
}
bind .shell.t <Control-Right> continue
bind .shell.t <Shift-Right> continue
bind .shell.t <Key-Home> {if {[cursorHome %W]} then break}

bind .shell.t <Key-Return> {
  if {[processReturnKey %W]} then break
}
bind .shell.t <Shift-Return> {
  %W insert insert \n
  break
}

bind .shell.t <Control-Up> {
  apply {
    win {
      lassign\
        [$win tag prevrange prompt "insert linestart - 1chars"] - idx
      if {$idx eq ""} then {
        set idx 1.0
      } elseif {[$win get $idx] eq " "} then {
        append idx +1chars
      }
      $win mark set insert $idx
    }
  } %W
  break
}

proc busyCursor {{win .shell.t}} {
  set cursor [$win cget -cursor]
  $win configure -cursor watch
  update
  $win configure -cursor $cursor
}

proc evalInputIfComplete {{win .shell.t}} {
  set src [inputText $win]
  if {![info complete $src]} then {
    return false
  } else {
    $win mark set insert [$win index end]
    if {[catch {set result [shell eval $src]} err]} then {
      message $err error
    } else {
      message $result
    }
    return true
  }
}

proc processReturnKey {{win .shell.t}} {
  busyCursor $win
  if {![copyCurrentLine $win]} then {
    $win insert "insert lineend" \n ""
    # $win see insert
    evalInputIfComplete $win
    after idle "$win see insert"
  }
  return true
}

proc message {msg {tag result} {win .shell.t}} {
  $win mark set insert end
  if {$msg ne ""} then {
    $win insert insert $msg $tag
  }
  prompt $win
  $win see insert
}

proc cursorHome {{win .shell.t}} {
  set range\
    [$win tag prevrange prompt "insert lineend" "insert linestart"]
  if {$range eq ""} then {
    return false
  } else {
    lassign $range - start
    if {[$win get $start] eq " "} then {
      $win mark set insert $start+1chars
    } else {
      $win mark set insert $start
    }
    return true
  }
}

proc prompt {{win .shell.t}} {
  $win mark set insert end
  if {[$win compare "insert linestart" < "insert lineend"]} then {
    $win insert insert \n ""
  }
  $win insert insert "%" prompt " "
  $win see insert
}

prompt
.shell.t delete 1.0

proc inputText {{win .shell.t}} {
  # content of last input line
  set promptRange [$win tag prevrange prompt end 1.0]
  lassign "$promptRange 0 1.0" - start
  if {[$win get $start] eq " "} then {
    set start $start+1chars
  }
  $win get $start end-1chars
}

proc copyCurrentLine {{win .shell.t}} {
  # copy current line to end of .shell.t
  set prev [$win tag prevrange prompt insert 1.0]
  if {$prev eq ""} then {
    set start 1.0
  } else {
    lassign $prev - start
    if {[$win get $start] eq " "} then {
      set start $start+1chars
    }
  }
  set next [$win tag nextrange prompt $start end]
  if {$next eq ""} then {
    # at end of text window, so do nothing
    return false
  } else {
    lassign $next end0
    set end $end0
    set nextResultRange [$win tag nextrange result $start end]
    if {$nextResultRange ne ""} then {
      lassign $nextResultRange end1
      if {[$win compare $end1 < $end]} then {
        set end $end1
      }
    }
    set nextErrorRange [$win tag nextrange error $start end]
    if {$nextErrorRange ne ""} then {
      lassign $nextErrorRange end2
      if {[$win compare $end2 < $end]} then {
        set end $end2
      }
    }
    set line [string trim [$win get $start $end] \n]
    $win mark set insert end
    $win insert insert $line
    $win see insert
    return true
  }
}

proc shellPuts args {
  set t .shell.t
  # $t insert insert \n ""
  switch -exact -- [llength $args] {
    1 {
      lassign $args arg
      $t insert end $arg\n result
      $t see insert
    }
    2 {
      lassign $args how text
      switch -exact -- $how {
        -nonewline {
          $t insert end $text result
        }
        stdout {
          $t insert end $text\n result
        }
        stderr {
          $t insert end $text\n error
        }
        default {
          shell eval __puts__ $args
        }
      }
    }
    default {
      shell eval __puts__ $args
    }
  }
}

proc selectToClosingChar win {
  busyCursor $win
  set char [$win get insert]
  # international quotes
  set dict { „ “ ‚ ‘ “ ” ‘ ’ » « › ‹ « » ‹ › ( ) [ ] }
  set keys [dict keys $dict]
  #
  if {$char ni [list \u007b \u0022 {*}$keys]} then {
    return false
  }
  switch -exact -- $char {
    \" {
      set closeChar \"
    }
    \{ {
      set closeChar \}
    }
    default {
      set closeChar [dict get $dict $char]
    }
  }
  set start insert
  while true {
    set end [$win search $closeChar $start+1chars end]
    if {$end eq ""} then {
      return false
    }
    set txt [$win get insert $end+1chars]
    if {$char in $keys} then {
      lappend map \{ " " \} " "
      switch -exact -- $char {
        ( {
          lappend map ( \{ ) \}
        }
        \[ {
          lappend map \[ \{ \] \}
        }
      }
      set txt [string map $map $txt]
    }
    if {[info complete $txt]} then {
      $win tag remove sel 1.0 end
      $win tag add sel insert $end+1chars
      return true
    }
    set start $end
  }
  return false
}

interp create shell
interp alias shell send "" send
interp alias shell wm "" wm
interp alias shell winfo "" winfo
shell eval rename puts __puts__
shell alias puts shellPuts
shell eval {
  proc echo args {puts $args}
  proc aloud args {putsFlat $args; uplevel $args}
  proc putsFlat str {puts [regsub -all {\n\s*} $str _]}
  proc putsVars args {
    puts [concat {*}[lmap var $args {list $var [uplevel set $var]}]]
  }
  proc sourceCode proc {
    # return source code of procedure $proc
    set proc [uplevel [list namespace origin $proc]]
    set arglist [list ]
    foreach arg [info args $proc] {
      if {[info default $proc $arg defaultvalue]} then {
        lappend arglist [list [list $arg] $defaultvalue]
      } else {
        lappend arglist [list $arg]
      }
    }
    list proc [namespace origin $proc] $arglist [info body $proc]
  }
  proc cat file {
    set chan [open $file r]
    set result [read $chan]
    close $chan
    set result
  }
}

proc evalExpr expr {
  if {[catch {shell eval $expr} result]} then {
    message $result error
  } else {
    message $result
  }
}

# main

if {[info exists argv] && $argv ne ""} then {
  evalExpr [lindex $argv 0]
} else {
  .shell.t delete 1.0 end
  catch {.shell.t insert end [exec fortune]\n\n result}
  .shell.t insert end\
    "Hint: Key sequence Escape, Space toggles text wrap!\n" prompt
  prompt
}

shell eval namespace import tcl::mathop::* tcl::mathfunc::*