slif-precedence.tcl

# -*- tcl -*-
##
# (c) 2017 Andreas Kupries http://wiki.tcl.tk/andreas%20kupries
#                          http://core.tcl.tk/akupries/
##
# This code is BSD-licensed.

# SLIF support. Transformation of precedenced priority rules into
#               non-precedenced form.
##
# See doc/precedence-rewrite
# See doc.1/facts-precedence.txt

# # ## ### ##### ######## #############
## Administrivia

# @@ Meta Begin
# Package marpa::slif::precedence 0
# Meta author      {Andreas Kupries}
# Meta category    {Parser/Lexer Generator}
# Meta description Part of TclMarpa. Grammar transformer.
# Meta description Rewrites precedenced priority rules into sets where
# Meta description the precedence is directly encoded in the structure
# Meta description of the rules
# Meta location    http:/core.tcl.tk/akupries/marpa
# Meta platform    tcl
# Meta require     {Tcl 8.5}
# Meta require     TclOO
# Meta require     debug
# Meta require     debug::caller
# Meta require     marpa::util
# Meta subject     marpa transform precedence
# @@ Meta End

# Notes
# - Precedences are integers <= 0.
# - The tightest precedence is 0.
# - The loosest  precedence is some K <= 0
#
# - tighter x --> x+1 for x < 0, 0 for x == 0
# - looser  x --> x-1 for K < x, K for x == K
#
# Assumptions:
# - E's loosest precedence is K < 0
# - E is the LHS of the precedenced rules
# - E is recursive, i.e. appears in at least one RHS
#
# Rewrite rules
##
# 1. Replace E with
#	(( E ::= E[K] ))
#
# 2. Add
#	(( E[x] ::= E[tighter(x)] ))
#	for all x in [K...1]
#
# 3. Add
#	(( E[x] ::= ... E[x] ... E[tighter(x)] ... ))
#	for (( E ::= ... E ... E ... ))
#	[left-assoc, at precedence x]
#
# 4. Add
#	(( E[x] ::= ... E[tighter(x)] ... E[x] ... ))
#	for (( E ::= ... E ... E ... ))
#	[right-assoc, at precedence x]
#
# 5. Add
#	(( E[x] ::= ... E[K] ... ))	/f.a E in the input
#	for (( E ::= ... E ... ))
#	    [group-assoc, at precedence x]
#
# Notes on the priority rules in the result:
# - All are at precedence level 0, assoc "left".
# - In case of L0 the attributes action, mask and assoc are
#   left out, otherwise see below.
# - All from (3,4,5) have the
#   -	action,
#   -	mask, and
#   -	name
#   of their origin rule.
# - All from (1, 2) have
#   -	action {special hide}, --  A form of `first` which prevents the
#                                \ symbol from making its own AST node.
#   -	mask {0}, and
#   -	no name.

# In generated symbols, i.e. FOO((x)) for origin FOO at level x the
# levels are inverted (0-x), stting -K the loosest precedence.
# Precedence 0 keeps being the tightest. This is easier to read, while
# the negative precedence levels were easier to generate from within
# the semantics.

# Thinking about this now I am not sure what I was thinking at the
# time. Incrementing up to mean `looser precedence` should work just
# as well. <-- Consider FUTURE TODO to redo this part of the
# semantics, and here, of course.

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

package require Tcl 8.5
package require TclOO         ;# Implies Tcl 8.5 requirement.
package require debug
package require debug::caller
package require marpa::util

debug define marpa/slif/precedence

# # ## ### ##### ######## #############

namespace eval ::marpa::slif::precedence {
    namespace export rewrite rewrite1 2container
    namespace ensemble create
    namespace import ::marpa::X
}

# # ## ### ##### ######## #############
## Public API

proc ::marpa::slif::precedence::rewrite {container} {
    debug.marpa/slif/precedence {}
    set commands {}
    foreach layer {g1 l0} {
	foreach sym [$container $layer symbols] {
	    # Without an actual range of precedences a rewrite is not
	    # worth it. This also automatically exludes the trivially
	    # non-recursive rules (atoms and quantified) from
	    # consideration.
	    set min_p [$container $layer min-precedence $sym]
	    if {$min_p == 0} continue

	    # Exclude priority rules which are not recursive.  This is
	    # a more expensive check, iterating over all the
	    # alternates and their elements, thus why it is the second
	    # check after the easier test for a precedence range.
	    if {![$container $layer recursive $sym]} continue

	    lappend commands {*}[rewrite1 $layer $sym $min_p [$container $layer get $sym]]
	}
    }
    return $commands
}

proc ::marpa::slif::precedence::2container {rewrite container} {
    debug.marpa/slif/precedence {}
    foreach command $rewrite {
	$container {*}$command
    }
    return
}

proc ::marpa::slif::precedence::rewrite1 {grcode lhs min alternatives} {
    debug.marpa/slif/precedence {}
    # alternatives :: list(alter)
    # alter        :: tuple(rhs precedence ...)
    # rhs          :: list(symbol)
    # ...          :: {*}dict ( name action assoc mask )
    # action, assoc, mask are G1 only
    # assoc defaults to "left".

    # result :: list(commands)

    set result {}
    R $lhs

    # Note:
    # - "attr" is used by "P" to fill in the attributes of the new
    #   priority rules.

    set smin [S $min]
    set attr [list action {special hide} mask {0}]

    # Rewrite (1) - Ground
    P $lhs [list $smin]

    # Rewrite (2) - Spine
    for {
	set current $min
	set tighter [expr {$min + 1}]
    } {$current < 0} {
	incr current
	incr tighter} {
	P [S $current] [list [S $tighter]]
    }

    # Rewrite (3-5) - Rules per assoc type
    foreach alter $alternatives {
	P {*}[MapAlter $lhs $alter $smin]
    }

    return $result
}

# # ## ### ##### ######## #############
## Internal helpers

proc ::marpa::slif::precedence::MapAlter {lhs alter smin} {
    debug.marpa/slif/precedence {}
    # Export to caller for import into the following P.
    upvar 1 attr attr

    set attr [lassign $alter __type__ rhs precedence]
    if {[dict exists $attr assoc]} {
	set assoc [dict get $attr assoc]
    } else {
	set assoc left
    }

    set scurrent [S $precedence]
    set stighter [S [expr {min($precedence + 1,0)}]]

    switch -exact -- $assoc {
	left {
	    # Rewrite (3)
	    # E[x] ::= ... E[x] ... E[tighter(x)]...
	    set newrhs [MapFirst $rhs $lhs $scurrent $stighter]
	}
	right {
	    # Rewrite (4)
	    # E[x] ::= ... E[tighter(x)] ... E[x]...
	    # Like left, but in reverse.
	    set newrhs [lreverse [MapFirst [lreverse $rhs] $lhs $scurrent $stighter]]
	}
	group {
	    # Rewrite (5)
	    # E[x] ::= ... E[K] ..., for all E in rhs
	   set newrhs [MapAll $rhs $lhs $smin]
       }
	default {
	    X "Bad assocation $assoc" SLIF PRECEDENCE BAD ASSOC
	}
    }
    return [list $scurrent $newrhs]
}

proc ::marpa::slif::precedence::MapFirst {rhs lhs newfirst newplus} {
    debug.marpa/slif/precedence {}
    set new $newfirst
    return [lmap sym $rhs {
	if {$sym eq $lhs} {
	    set res $new
	    set new $newplus
	    set res
	} else {
	    set sym
	}
    }]
}

proc ::marpa::slif::precedence::MapAll {rhs lhs new} {
    debug.marpa/slif/precedence {}
    return [lmap sym $rhs {
	if {$sym eq $lhs} {
	    set new
	} else {
	    set sym
	}
    }]
}

proc ::marpa::slif::precedence::S {k} {
    debug.marpa/slif/precedence {}
    upvar 1 lhs lhs
    return "${lhs}(([expr {-$k}]))"
}

proc ::marpa::slif::precedence::R {sym} {
    debug.marpa/slif/precedence {}
    upvar 1 grcode grcode result result
    lappend result [list $grcode remove $sym]
    return
}

proc ::marpa::slif::precedence::P {sym rhs} {
    debug.marpa/slif/precedence {}
    upvar 1 grcode grcode result result attr attr

    set newattr $attr
    dict set newattr assoc left
    if {$grcode eq "l0"} {
	dict unset newattr action
	dict unset newattr mask
	dict unset newattr assoc
    }

    lappend result [list $grcode priority-rule $sym $rhs 0 {*}$newattr]
    return
}

# # ## ### ##### ######## #############
package provide marpa::slif::precedence 0
return