# -*- tcl -*-
# ### ### ### ######### ######### #########

## This package provides a number of utility commands to
## transformations for common operations. It assumes a 'Normalized PE
## Grammar Tree' as input, possibly augmented with attributes coming
## from transformation not in conflict with the base definition.

# ### ### ### ######### ######### #########
## Requisites

package require page::util::quote

namespace eval ::page::util::peg {
    namespace export \
	    symbolOf symbolNodeOf \
	    updateUndefinedDueRemoval \
	    flatten peOf printTclExpr \
	    getWarnings printWarnings

    # Get the peg char de/encoder commands.
    # (unquote, quote'tcl).

    namespace import ::page::util::quote::*
}

# ### ### ### ######### ######### #########
## API

proc ::page::util::peg::symbolNodeOf {t n} {
    # Given an arbitrary root it determines the node (itself or an
    # ancestor) containing the name of the nonterminal symbol the node
    # belongs to, and returns its id. The result is either the root of
    # the tree (for the start expression), or a definition mode.

    while {![$t keyexists $n symbol]} {
	set n [$t parent $n]
    }
    return $n
}

proc ::page::util::peg::symbolOf {t n} {
    # As above, but returns the symbol name.

    return [$t get [symbolNodeOf $t $n] symbol]
}

proc ::page::util::peg::updateUndefinedDueRemoval {t} {
    # The removal of nodes may have caused symbols to lose one or more
    # users. Example: A used by B and C, B is reachable, C is not, so A
    # now loses a node in the expression for C calling it, or rather
    # not anymore.

    foreach {sym def} [$t get root definitions] {
	set res {}
	foreach u [$t get $def users] {
	    if {![$t exists $u]} continue
	    lappend res $u
	}
	$t set $def users $res
    }

    # Update the knowledge of undefined nonterminals. To be used when
    # a transformation can remove invokations of undefined symbols,
    # and is not able to generate such invokations.

    set res {}
    foreach {sym invokers} [$t get root undefined] {
	set sres {}
	foreach n $invokers {
	    if {![$t exists $n]} continue
	    lappend sres $n
	}
	if {[llength $sres]} {
	    lappend res $sym $sres
	}
    }
    $t set root undefined $res
    return
}

proc ::page::util::peg::flatten {q t} {
    # Flatten nested x-, or /-operators.
    # See peg_normalize.tcl, peg::normalize::ExprFlatten

    foreach op {x /} {
	# Locate all x operators, whose parents are x oerators as
	# well, then go back to the child operators and cut them out.

	$q query \
		tree          withatt op $op \
		parent unique withatt op $op \
		children      withatt op $op \
		over n {
	    $t cut $n
	}
    }
    return
}

proc ::page::util::peg::getWarnings {t} {
    # Look at the attributes for problems with the grammar and issue
    # warnings. They do not prevent us from writing the grammar, but
    # still represent problems with it the user should be made aware
    # of.

    array set msg {}
    array set undefined [$t get root undefined]
    foreach sym [array names undefined] {
	set msg($sym) {}
	foreach ref $undefined($sym) {
	    lappend msg($sym) "Undefined symbol used by the definition of '[symbolOf $t $ref]'."
	}
    }

    foreach {sym def} [$t get root definitions] {
	if {[llength [$t get $def users]] == 0} {
	    set msg($sym) [list "This symbol has been defined, but is not used."]
	}
    }

    return [array get msg]
}

proc ::page::util::peg::printWarnings {msg} {
    if {![llength $msg]} return

    set dict {}
    set max -1
    foreach {k v} $msg {
	set l [string length [list $k]]
	if {$l > $max} {set max $l}
	lappend dict [list $k $v $l]
    }

    foreach e [lsort -dict -index 0 $dict] {
	foreach {k msgs l} $e break

	set off [string repeat " " [expr {$max - $l}]]
	page_info "[list $k]$off : [lindex $msgs 0]"

	if {[llength $msgs] > 1} {
	    set indent [string repeat " " [string length [list $k]]]
	    foreach m [lrange $msgs 1 end] {
		puts stderr "  $indent$off : $m"
	    }
	}
    }
    return
}

proc ::page::util::peg::peOf {t eroot} {
    set op [$t get $eroot op]
    set pe [list $op]

    set ch [$t children $eroot]

    if {[llength $ch]} {
	foreach c $ch {
	    lappend pe [peOf $t $c]
	}
    } elseif {$op eq "n"} {
	lappend pe [$t get $eroot sym]
    } elseif {$op eq "t"} {
	lappend pe [unquote [$t get $eroot char]]
    } elseif {$op eq ".."} {
	lappend pe \
		[unquote [$t get $eroot begin]] \
		[unquote [$t get $eroot end]]

    }
    return $pe
}

proc ::page::util::peg::printTclExpr {pe} {
    list [PrintExprSub $pe]
}

# ### ### ### ######### ######### #########
## Internal

proc ::page::util::peg::PrintExprSub {pe} {
    set op   [lindex $pe 0]
    set args [lrange $pe 1 end]

    #puts stderr "PE [llength $args] $op | $args"

    if {$op eq "t"} {
	set a [lindex $args 0]
	return "$op [quote'tcl $a]"
    } elseif {$op eq ".."} {
	set a [lindex $args 0]
	set b [lindex $args 1]
	return "$op [quote'tcl $a] [quote'tcl $b]"
    } elseif {$op eq "n"} {
	return $pe
    } else {
	set res $op
	foreach a $args {
	    lappend res [PrintExprSub $a]
	}
	return $res
    }
}

# ### ### ### ######### ######### #########
## Ready

package provide page::util::peg 0.1