Error context from ocamlc

[Mike Spivey <mike@comlab.ox.ac.uk>]

I'm quite happy using emacs, but some of my students prefer other
editors.  To help them, I've written the script below, which can take
the error messages output by ocamlc and display the source line in the
same way the Caml Light compiler used to do.

-- Mike


Je suis content avec l'editeur emacs, mais quelques d'entre mes
etudiants preferent des autre editeurs.  Donc j'ai ecrit le petit
script ci-joint, qui prend les messages produit par ocamlc, et montre
la ligne du source, dans le meme style utilise par Caml Light.

-- Maik


#!/usr/bin/tclsh

# Usage: 
#    "ocamlerror FILE LINE BEG-END" 
#	to locate error in FILE on LINE, characters BEG-END
#    "ocamlerror ERRFILE"
#	to locate all errors reported in ERRFILE
#    "ocamlc FILE.ml 2>&1 | ocamlerror"
#	to locate errors reported by compiler

# lsplit -- split a list into multiple variables
proc lsplit {xs args} {
    set n [llength $args]
    for {set i 0} {$i < $n} {incr i} {
	uplevel [list set [lindex $args $i] [lindex $xs $i]]
    }
}

# getline -- fetch single line from file
proc getline {file line} {
    set f [open $file]
    for {set i 0} {$i < $line} {incr i} {
	gets $f buf
    }
    close $f
    return $buf
}

# tab -- compute tab location
proc tab {n} {
    return [expr {($n+8)/8*8}]
}

# locate -- echo line with error location
proc locate {file line chars} {
    set buf [getline $file $line]

    # Analyse $chars into $beg and $end
    regexp {([0-9]+)-([0-9]+)} $chars dummy beg end
    if {$beg == $end} {incr end}
    if {$end > [string length $buf]} {
	set buf "$buf ..."
	set end [string length $buf]
    }

    puts $buf

    # Output spaces up to position BEG
    for {set i 0; set j 0} {$i < $beg} {incr i} {
	if {[string index $buf $i] == "\t"} {
	    puts -nonewline "\t"; set j [tab $j]
	} else {
	    puts -nonewline " "; incr j
	}
    }

    # Output markers up to position END
    for {} {$i < $end} {incr i} {
	if {[string index $buf $i] == "\t"} {
	    for {set k [tab $j]} {$j < $k} {incr j} {
		puts -nonewline "^"
	    }
	} else {
	    puts -nonewline "^"; incr j
	}
    }

    puts ""
}

proc scanfile {f} {
    global status

    while {[gets $f buf] >= 0} {
	puts $buf
	if {[regexp \
		{^File "(.*)", line ([0-9]+), characters ([0-9]+-[0-9]+):} \
		$buf dummy file line chars]} {
	    set status 1
	    locate $file $line $chars
	}
    }
}

set status 0

proc usage {} {
    global argv0
    puts stderr "Usage: ocamlerror file line begin-end"
    puts stderr "   or: ocamlerror errfile"
    puts stderr "   or: ocamlc file.ml 2>&1 | ocamlerror"
    exit 2
}

proc main {} {
    global argv
    switch [llength $argv] {
	0 {scanfile stdin}
	1 {set f [open [lindex $argv 0]]; scanfile $f}
	3 {lsplit $argv file line chars; locate $file $line $chars}
	default {usage}
    }
}

if {[catch main msg]} {
    puts "ocamlerror: $msg"
    exit 2
}

exit $status