#!/usr/bin/wish
# interactive Tcl/Tk interface to ppl.
# $Id: ppli.in,v 1.14 2000/07/09 18:43:39 selinger Exp $

# One can invoke this by typing "wish ppli.in". Or type "make ppli" to
# make a stand-alone executable (which is generated simply by adding
# the installation dependent path name of the wish shell to the
# beginning of this file).

# ----------------------------------------------------------------------
# todo:
# make window update less destructive (keep widgets where possible)
# deal better with non-terminating ppl call (retrieve output by need)
# make "interrupt" button to deal with non-terminating ppl call

# ----------------------------------------------------------------------
# special features to document:
# up and down keys for filename history
# left and right keys in number field for stepper

# ----------------------------------------------------------------------
# assumptions made about interface with ppl: assume that ppl
# recognizes the --stdin option, and the --typed, --untyped,
# --compile, --reduce, and --step options. If --stdin is given, input
# is read from stdin without any further prompt, until end-of-file. If
# --typed is given, the first line of output contains the principal
# type, possibly preceded by some words and a colon. If --untyped is
# given, no type information is output. If --compile is given, the
# compiled code is output on a line-by-line basis. If --reduce is
# given, the normal form is output on a single line. If --step is
# given, the reduction sequence is output, one term per line. In all
# these cases, output is to stdout.  Error messages are of the form
# "file: error" or "file:c.13-40: error", and they are written to
# stderr. If --stdin is given, then "file" is printed as "(stdin)". 
# Exit status is 0 on normal exit, and nonzero on error. 

# ----------------------------------------------------------------------
# physical layout of user interface

# most important global variables affected by the user interface: 
#  untypedflag (boolean)           - suppress typing?
#  textarea (text widget)          - the PPL program
#  filehistory(list) (string list) - list of files that have been opened
#  filehistory(i)    (int)         - where we are in the file history

# set window title
wm title . "Interactive PPL"

# create hierarchical structure of frames and widgets

# status and command line
set status [frame .status -bd 4]
  set statusline [label $status.line -anchor w]
  pack $statusline -side bottom -fill x
pack $status -side bottom -fill x

# frame for action buttons
set action [frame .action -bd 2 -relief raised]
  set actionlabel [label $action.label -text "Actions:"]
  set compilebutton [button $action.compile -text Compile -command Compile]
  set reducebutton [button $action.reduce -text Reduce -command Reduce]
  set stepbutton [button $action.step -text Step -command Step]
  set untypedbutton [checkbutton $action.untyped -text Untyped \
	  -variable untypedflag]
  set quitbutton [button $action.quit -text Quit -command exit]
  pack $actionlabel -side top -fill x
  pack $compilebutton $reducebutton $stepbutton -side top -fill x \
	  -ipady 8 -pady 3 -padx 5
  pack $untypedbutton -side top -fill x
  pack $quitbutton -side bottom -fill x -pady 3 -padx 5
pack $action -side right -fill y -padx 5 -pady 5

# frame for filename entry
set file [frame .file -bd 2 -relief raised]
  set filelabel [label $file.label -text File: -padx 0]
  set fileentry [entry $file.entry -width 20 -textvariable filename -bg white]
  set openbutton [button $file.open -text Open -command {Open $filename}]
  pack $filelabel -side left
  pack $fileentry -side left -fill x -expand true
  pack $openbutton -side right -pady 1 -padx 5
pack $file -side bottom -fill x -padx 5 -pady 5
  
# frame for program entry
set input [frame .input -bd 0 -relief solid]
  # title of program entry area
  set title [frame $input.title]
    set inputlabel [label $title.label -text "Input a PPL Program:"]
    set clearbutton [button $title.clear -text "Clear Display" \
	    -command Clear]
    pack $inputlabel -side left
    pack $clearbutton -side right
  pack $title -side top -fill x

  # text entry area
  set text [frame $input.text]
    set textarea [text $text.area -setgrid true -wrap word \
	    -width 42 -height 14 -bg white \
	    -yscrollcommand "$text.scroll set"]
    set scrollbar [scrollbar $text.scroll -orient vert \
	    -command "$textarea yview"]
    pack $scrollbar -side right -fill y
    pack $textarea -side left -fill both -expand true
  pack $text -fill both -expand true
pack $input -fill both -expand true -padx 5 -pady 5

# set up handlers for special keyboard events
bind $fileentry <Return> {Open $filename}
bind $fileentry <Key-Up> "History filehistory filename $fileentry up"
bind $fileentry <Key-Down> "History filehistory filename $fileentry down"
bind $fileentry <Control-u> "$fileentry delete 0 end"

# ----------------------------------------------------------------------
# procedures to handle various events

proc Status {{msg "ok"}} {
    global statusline
    $statusline config -text "Status: $msg"
    update idletasks
}

proc Clear {} {
    global textarea
    $textarea delete 1.0 end
    Status
}

proc Open {filename} {
    global textarea filelabel
    set filename [string trim $filename]
    if {[string length $filename]==0} {
	Status "Open: please enter file name"
    } else {
	Addtohistory filehistory $filename
	if [catch {open $filename r} fileId] {
	    Status "Open: $fileId"
	} else {
	    Status "Reading file..."
	    $textarea delete 1.0 end	
	    if [catch {
		while {[gets $fileId line] >= 0} {
		    $textarea insert end "$line\n"
		}
		close $fileId
	    } error] {
		Status "Open: $error"
	    } else {
		Status
	    }
	}
    }
}	

# append element to the given history list
proc Addtohistory {history elt} {
    upvar #0 ${history}(list) list
    upvar #0 ${history}(i) i

    set n [llength $list]
    if {$i>=$n || [string compare [lindex $list $i] $elt]} {
	set j [lsearch -exact $list $elt]
	if {$j != -1} {
	    set list [lreplace $list $j $j]
	}
	lappend list $elt
	set i [llength $list]
    }
}    

# move up or down in the given history list
proc History {history textvar widget {cmd ""}} {
    upvar #0 ${history}(list) list
    upvar #0 ${history}(i) i
    upvar #0 ${history}(saved) saved
    upvar $textvar text
    
    set n [llength $list]
    if {$i==$n} {
	set saved $text
    }
    switch -- $cmd {
	up {
	    set i [expr $i-1]
	    if {$i>=0 && ![string compare [string trim $saved] \
		    [lindex $list $i]]} {
		set i [expr $i-1]
	    }
	}
	down {
	    incr i
	    if {$i<$n && ![string compare [string trim $saved] \
		    [lindex $list [expr $i]]]} {
		incr i
	    }
	}
    }
    if {$i>$n} {set i $n}
    if {$i< 0} {set i  0}

    if {$i==$n} {
	set text $saved
    } else {
	set text [lindex $list $i]
    }
    $widget icursor end
    Status
}

proc Compile {} {
    Status compiling...
    Action Compile --compile .compiled "Compiler Output:" 50 25 run
}

proc Reduce {} {
    Status reducing...
    Action Reduce --reduce .reduced "Reduced Term:" 50 5
}

proc Step {} {
    Status reducing...
    Action Step --step .step "Step-wise Reduction:" 50 5 step
}

# Action ppl with $action, and display result in $window with $title.
# $name is the name of the button pressed to invoke this command.

proc Action {name action window title textw texth args} {
    global textarea untypedflag
    set step [expr [lsearch $args step]>=0]
    set run [expr [lsearch $args run]>=0]
    set cmd [list ppl $action [Untypedoption] --stdin]
    set inputvalue [$textarea get 1.0 end]
    if {[string length [string trim $inputvalue]]==0} {
	Status "$name: please enter PPL program"
    } else {
	if [catch {
	    set pipe [open "|[concat $cmd << [list $inputvalue]]"]
	    if {!$untypedflag} {
		set ptype [Tail [gets $pipe]]
	    }
	    set value [read $pipe]
	    close $pipe
	} error] {
	    PPLError $name $error
	} else {
	    if {$step} {
		set valuelist [Linelist $value]
	        set cmd [list MakePPLOutput $window $title $textw \
		    $texth $valuelist step]
		if {!$untypedflag} {
		  set cmd [concat $cmd type $ptype]
		}
		eval $cmd
	    } else {
	        set cmd [list MakePPLOutput $window $title $textw \
		    $texth $value]
		if {!$untypedflag} {
		  set cmd [concat $cmd type $ptype]
		}
		if {$run} {
		  set cmd [concat $cmd run]
		}
		eval $cmd
	    }
	    Status
	}
    }
}

# handle an error caused by ppl: suppress filename and highlight error
# characters if possible.
proc PPLError {cmd error} {
    global textarea
    if {[string first "(stdin):" $error] == 0} {
	set error [Tail $error]
	set i [scan $error {c.%d-%d:%s} x0 x1 rest]
	if {$i==3} {
	    Highlight $textarea $x0 $x1
	}
    }
    Status "$cmd: $error"
}

proc Lambdify {text} {
    while {[set i [$text search -- "\\" 1.0]]!=""} {
	$text delete $i
	$text insert $i "l" {greek}
    }
}

proc Highlight {text x0 x1} {
    set value [$text get 1.0 end]
    set i0 [Index $value $x0]
    set i1 [Index $value $x1]
    $text tag remove sel 1.0 end
    $text tag add sel $i0 $i1
    $text mark set insert $i0
    $text see $i0
    focus $text
}

proc Index {value char} {
    set list [split [string range $value 0 [expr $char-1]] "\n"]
    set line [llength $list]
    set pos [string length [lindex $list end]]
    return $line.$pos
}

# make or refresh a toplevel named $window, with wm title "PPL Output"
# and title label $title, in which a text area of width $textw and
# height $texth is displayed. If args contains "type t", then display
# principal type t. If args contains "step", then include stepper.
# The text area either contains $value, or a line of $value at a time
# (in the case of step).

proc MakePPLOutput {window title textw texth value args} {

    if {-1==[lsearch $args type]} {
	set type ""
    } else {
	set type [lindex $args [expr 1+[lsearch $args type]]]
    }
    set step [expr [lsearch $args step]>=0]
    set run [expr [lsearch $args run]>=0]
    
    Resettoplevel $window

    wm title $window "PPL Output"
      set frame [frame $window.frame]
        set titleframe [frame $frame.title]
          set label [label $titleframe.label -text $title]
          set close [button $titleframe.close -text "Close" \
  		-command "destroy $window"]
          pack $label -side left
          pack $close -side right -pady 2
	  if {$run} {
	    set runbutton [button $titleframe.runbutton -text "Run" \
		    -command "Run $frame.text.text"]
	    pack $runbutton -side right -pady 2
	  }
        pack $titleframe -side top -fill x
        if {$type!=""} {
	    set typeframe [frame $frame.type]
	      set typelabel [label $typeframe.label -text "Principal Type:"]
	      set typedisp [text $typeframe.text \
		      -width [string length $type] -height 1 \
		      -bg white]
	      $typedisp insert 1.0 $type
	      $typedisp config -state disabled
	      pack $typelabel -side left
	      pack $typedisp -fill x -expand true
	    pack $typeframe -side top -fill x -pady 5
	} else {
	    destroy $frame.type
	}
	if {$step} {
	    set bfont {-size 16 -weight bold}
	    set stepframe [frame $frame.step]
	      set bback [button $stepframe.bback -text "<<" -font $bfont \
		      -command "StepRefresh $window bback"]
	      set back  [button $stepframe.back  -text "<"  -font $bfont \
		      -command "StepRefresh $window back"]
	      set linenum [entry $stepframe.linenum \
		      -textvariable steplinetext($window)\
		      -width 3 -bg white]
	      set forw  [button $stepframe.forw  -text ">"  -font $bfont \
		      -command "StepRefresh $window forw"]
	      set fforw [button $stepframe.fforw -text ">>" -font $bfont \
		      -command "StepRefresh $window fforw"]
  	      pack $bback $back $linenum $forw $fforw -side left -fill both \
		      -padx 5 -pady 3 -ipady 5 -ipadx 5
	    pack $stepframe -side bottom
	}
	set textframe [frame $frame.text] 
          set text [text $textframe.text -wrap word \
		  -width $textw -height $texth \
		  -yscrollcommand "$textframe.scroll set" -bg white]
	  $text tag config greek -font {symbol 12}
          set scroll [scrollbar $textframe.scroll -orient vert \
		  -command "$text yview"]
          pack $scroll -side right -fill y
          pack $text -side left -fill both -expand true
	pack $textframe -side top -fill both -expand true
      pack $frame -fill both -expand true -padx 5 -pady 5

    # initialize
	if {!$step} {
	    $text config -state normal
	    $text insert 1.0 $value
	    Lambdify $text
	    $text config -state disabled
	}
	if {$step} {
	    global stepcount stepvalues stepmax steptext \
		    steplinenum steplinetext

	    # set up handlers for special keyboard events
	    bind $linenum <Return> "StepRefresh $window"
	    bind $linenum <Key-Left> "StepRefresh $window back"
	    bind $linenum <Key-Right> "StepRefresh $window forw"
	    focus $linenum
	    
	    set stepcount($window) 0
	    set stepvalues($window) $value
	    set stepmax($window) [llength $value]
	    set steptext($window) $text
	    set steplinenum($window) $linenum
	    set steplinetext($window) 0
	    StepRefresh $window
	}
}

# displays string in stepper after optionally executing step command
proc StepRefresh {window {command ""}} {
    upvar #0 stepcount($window) count
    upvar #0 stepvalues($window) values
    upvar #0 stepmax($window) max
    upvar #0 steptext($window) text
    upvar #0 steplinenum($window) linenum
    upvar #0 steplinetext($window) linetext

    if {![catch {expr ($linetext)+0} error]} {
	set count $linetext
    }

    switch -- $command {
	forw {incr count}
	back {set count [expr $count-1]}
        fforw {set count [expr $max-1]}
        bback {set count 0}
    }

    if {$count >= $max} {set count [expr $max-1]}
    if {$count < 0} {set count 0}

    $text config -state normal
    $text delete 1.0 end
    $text insert 1.0 [lindex $values $count]
    Lambdify $text
    $text config -state disabled
    set linetext $count
    $linenum icursor end
}

# ----------------------------------------------------------------------
# "run" action

proc Run {pseudotext} {
    set inputvalue [$pseudotext get 1.0 end]
    set tmpfile "./tmp.wish"
    set cmd1 [list cat > $tmpfile.c << $inputvalue]
    set cmd2 [list gcc $tmpfile.c -o $tmpfile]
    if [catch {
	Status "writing pseudocode to $tmpfile.c..."
	eval [concat exec $cmd1]
	Status "compiling pseudocode..."
	eval [concat exec $cmd2]
	Status "running code..."
	set pipe [open "|$tmpfile"]
	set value [read $pipe]
	close $pipe
    } error] {
	PPLError Run $error
    } else {
	MakePPLOutput .run "Program Output:" 50 5 $value
	Status
    }
    eval [list exec rm $tmpfile.c $tmpfile]
}

# ----------------------------------------------------------------------
# auxiliary procedures

# returns "--untyped" or "--typed" depending on $untypedflag
proc Untypedoption {} {
    global untypedflag
    if {$untypedflag} {
	return "--untyped"
    } else {
	return "--typed"
    }
}

# returns the tail of a message of the form "head: tail"
proc Tail {s} {
    set i [string first ":" $s]
    if {$i==-1} {
	return [string trim $s]
    } else {
	return [string trim [string range $s [expr $i+1] end]]
    }
}

# return a list of the non-empty lines of a string s
proc Linelist {s} {
    set list1 [split $s "\n"]
    set list2 {}
    foreach i $list1 {
	if {[string trim $i]!=""} {
	    lappend list2 $i
	}
    }
    return $list2
}

# creates or recreates a toplevel named $w with no children
proc Resettoplevel {w} {
    if {![winfo exists $w]} {
	toplevel $w
    } else {
	destroy [winfo children $w]
    }
}    

# ----------------------------------------------------------------------
# initialize for interactive use

set untypedflag 0
set filehistory(list) {}
set filehistory(i)    0
set filehistory(saved) bogus
Status